This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Readability improvements.
[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
b38d579d
TC
9static const char code_point_warning[] =
10 "Strings with code points over 0xFF may not be mapped into in-memory file handles\n";
11
14d89041
NIS
12typedef struct {
13 struct _PerlIO base; /* Base "class" info */
14 SV *var;
15 Off_t posn;
f6c77cf1
NIS
16} PerlIOScalar;
17
0b057af7 18static IV
14d89041
NIS
19PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
20 PerlIO_funcs * tab)
f6c77cf1 21{
14d89041
NIS
22 IV code;
23 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
24 /* If called (normally) via open() then arg is ref to scalar we are
25 * using, otherwise arg (from binmode presumably) is either NULL
26 * or the _name_ of the scalar
27 */
82505891 28 if (arg && SvOK(arg)) {
cba44c14 29 if (SvROK(arg)) {
47d6f3d6
FC
30 if (SvREADONLY(SvRV(arg)) && !SvIsCOW(SvRV(arg))
31 && mode && *mode != 'r') {
b35bc0c6 32 if (ckWARN(WARN_LAYER))
76c6a213 33 Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify);
42bc49da 34 SETERRNO(EINVAL, SS_IVCHAN);
b35bc0c6
RGS
35 return -1;
36 }
14d89041 37 s->var = SvREFCNT_inc(SvRV(arg));
22ccb26d
BM
38 SvGETMAGIC(s->var);
39 if (!SvPOK(s->var) && SvOK(s->var))
40 (void)SvPV_nomg_const_nolen(s->var);
14d89041
NIS
41 }
42 else {
43 s->var =
44 SvREFCNT_inc(perl_get_sv
45 (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
46 }
564dc057 47 }
14d89041 48 else {
c2b90b61 49 s->var = newSVpvs("");
564dc057 50 }
5a2bc23b 51 SvUPGRADE(s->var, SVt_PV);
552908b1 52
14d89041 53 code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
47cc46ee 54 if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
526fd1b4
FC
55 {
56 sv_force_normal(s->var);
b162af07 57 SvCUR_set(s->var, 0);
2b2b0f4f 58 if (SvPOK(s->var)) *SvPVX(s->var) = 0;
526fd1b4 59 }
02c3c86b
TC
60 if (SvUTF8(s->var) && !sv_utf8_downgrade(s->var, TRUE)) {
61 if (ckWARN(WARN_UTF8))
b38d579d 62 Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning);
02c3c86b
TC
63 SETERRNO(EINVAL, SS_IVCHAN);
64 SvREFCNT_dec(s->var);
65 s->var = Nullsv;
66 return -1;
67 }
14d89041 68 if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
7f7e7b58 69 s->posn = SvOK(s->var) ? sv_len(s->var) : 0;
14d89041
NIS
70 else
71 s->posn = 0;
ffe0bb5a 72 SvSETMAGIC(s->var);
14d89041 73 return code;
f6c77cf1
NIS
74}
75
0b057af7 76static IV
14d89041 77PerlIOScalar_popped(pTHX_ PerlIO * f)
f6c77cf1 78{
14d89041
NIS
79 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
80 if (s->var) {
81 SvREFCNT_dec(s->var);
82 s->var = Nullsv;
83 }
84 return 0;
f6c77cf1
NIS
85}
86
0b057af7 87static IV
14d89041 88PerlIOScalar_close(pTHX_ PerlIO * f)
f6c77cf1 89{
14d89041
NIS
90 IV code = PerlIOBase_close(aTHX_ f);
91 PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
92 return code;
f6c77cf1
NIS
93}
94
0b057af7 95static IV
14d89041 96PerlIOScalar_fileno(pTHX_ PerlIO * f)
f6c77cf1 97{
c33e8be1 98 PERL_UNUSED_ARG(f);
14d89041 99 return -1;
f6c77cf1
NIS
100}
101
0b057af7 102static IV
14d89041 103PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
f6c77cf1 104{
14d89041 105 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
1d050e55 106 Off_t new_posn;
e94207f0 107
14d89041 108 switch (whence) {
42bc49da 109 case SEEK_SET:
1d050e55 110 new_posn = offset;
14d89041 111 break;
42bc49da 112 case SEEK_CUR:
1d050e55 113 new_posn = offset + s->posn;
14d89041 114 break;
42bc49da 115 case SEEK_END:
b6597275
FC
116 {
117 STRLEN oldcur;
118 (void)SvPV(s->var, oldcur);
1d050e55 119 new_posn = offset + oldcur;
14d89041 120 break;
b6597275 121 }
1d050e55
TC
122 default:
123 SETERRNO(EINVAL, SS_IVCHAN);
124 return -1;
14d89041 125 }
1d050e55 126 if (new_posn < 0) {
42bc49da
JH
127 if (ckWARN(WARN_LAYER))
128 Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
129 SETERRNO(EINVAL, SS_IVCHAN);
130 return -1;
14d89041 131 }
1d050e55 132 s->posn = new_posn;
14d89041 133 return 0;
f6c77cf1
NIS
134}
135
0b057af7 136static Off_t
14d89041 137PerlIOScalar_tell(pTHX_ PerlIO * f)
f6c77cf1 138{
14d89041
NIS
139 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
140 return s->posn;
f6c77cf1
NIS
141}
142
ffe0bb5a 143
0b057af7 144static SSize_t
ffe0bb5a
DM
145PerlIOScalar_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
146{
147 if (!f)
148 return 0;
149 if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
150 PerlIOBase(f)->flags |= PERLIO_F_ERROR;
151 SETERRNO(EBADF, SS_IVCHAN);
0ea86a10 152 Perl_PerlIO_save_errno(aTHX_ f);
ffe0bb5a
DM
153 return 0;
154 }
155 {
156 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
157 SV *sv = s->var;
158 char *p;
ab9f1586 159 STRLEN len;
63d073d2 160 STRLEN got;
ffe0bb5a 161 p = SvPV(sv, len);
b38d579d
TC
162 if (SvUTF8(sv)) {
163 if (sv_utf8_downgrade(sv, TRUE)) {
164 p = SvPV_nomg(sv, len);
165 }
166 else {
167 if (ckWARN(WARN_UTF8))
168 Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning);
169 SETERRNO(EINVAL, SS_IVCHAN);
170 return -1;
171 }
172 }
63d073d2
TC
173 /* I assume that Off_t is at least as large as len (which
174 * seems safe) and that the size of the buffer in our SV is
175 * always less than half the size of the address space
176 */
177 assert(sizeof(Off_t) >= sizeof(len));
178 assert((Off_t)len >= 0);
179 if ((Off_t)len <= s->posn)
ffe0bb5a 180 return 0;
63d073d2 181 got = len - (STRLEN)(s->posn);
c33e8be1 182 if ((STRLEN)got > (STRLEN)count)
ffe0bb5a
DM
183 got = (STRLEN)count;
184 Copy(p + (STRLEN)(s->posn), vbuf, got, STDCHAR);
185 s->posn += (Off_t)got;
186 return (SSize_t)got;
187 }
188}
189
0b057af7 190static SSize_t
14d89041 191PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
f6c77cf1 192{
14d89041
NIS
193 if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
194 Off_t offset;
195 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
196 SV *sv = s->var;
197 char *dst;
ffe0bb5a 198 SvGETMAGIC(sv);
c5a04db8
FC
199 if (!SvROK(sv)) sv_force_normal(sv);
200 if (SvOK(sv)) SvPV_force_nomg_nolen(sv);
eeee3e08
TC
201 if (SvUTF8(sv) && !sv_utf8_downgrade(sv, TRUE)) {
202 if (ckWARN(WARN_UTF8))
203 Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning);
204 SETERRNO(EINVAL, SS_IVCHAN);
205 return 0;
206 }
14d89041 207 if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
8af88444 208 dst = SvGROW(sv, SvCUR(sv) + count + 1);
14d89041
NIS
209 offset = SvCUR(sv);
210 s->posn = offset + count;
211 }
212 else {
b6597275 213 STRLEN const cur = SvCUR(sv);
4388f261
TC
214
215 /* ensure we don't try to create ridiculously large
216 * SVs on small platforms
217 */
d1992db0 218#if Size_t_size < Off_t_size
4388f261
TC
219 if (s->posn > SSize_t_MAX) {
220#ifdef EFBIG
221 SETERRNO(EFBIG, SS_BUFFEROVF);
222#else
223 SETERRNO(ENOSPC, SS_BUFFEROVF);
224#endif
225 return 0;
226 }
227#endif
228
8380d35a 229 if ((STRLEN)s->posn > cur) {
8af88444 230 dst = SvGROW(sv, (STRLEN)s->posn + count + 1);
b6597275
FC
231 Zero(SvPVX(sv) + cur, (STRLEN)s->posn - cur, char);
232 }
8af88444
BL
233 else if ((s->posn + count) >= cur)
234 dst = SvGROW(sv, (STRLEN)s->posn + count + 1);
14d89041 235 else
ffe0bb5a 236 dst = SvPVX(sv);
14d89041
NIS
237 offset = s->posn;
238 s->posn += count;
239 }
240 Move(vbuf, dst + offset, count, char);
8af88444 241 if ((STRLEN) s->posn > SvCUR(sv)) {
4a9d6100 242 SvCUR_set(sv, (STRLEN)s->posn);
8af88444
BL
243 dst[(STRLEN) s->posn] = 0;
244 }
ffe0bb5a
DM
245 SvPOK_on(sv);
246 SvSETMAGIC(sv);
14d89041 247 return count;
09bf542c 248 }
14d89041
NIS
249 else
250 return 0;
f6c77cf1
NIS
251}
252
0b057af7 253static IV
14d89041 254PerlIOScalar_fill(pTHX_ PerlIO * f)
f6c77cf1 255{
c33e8be1 256 PERL_UNUSED_ARG(f);
14d89041 257 return -1;
f6c77cf1
NIS
258}
259
0b057af7 260static IV
14d89041 261PerlIOScalar_flush(pTHX_ PerlIO * f)
f6c77cf1 262{
c33e8be1 263 PERL_UNUSED_ARG(f);
14d89041 264 return 0;
f6c77cf1
NIS
265}
266
0b057af7 267static STDCHAR *
14d89041 268PerlIOScalar_get_base(pTHX_ PerlIO * f)
f6c77cf1 269{
14d89041
NIS
270 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
271 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
ffe0bb5a 272 SvGETMAGIC(s->var);
14d89041
NIS
273 return (STDCHAR *) SvPV_nolen(s->var);
274 }
9849c14c 275 return (STDCHAR *) NULL;
f6c77cf1
NIS
276}
277
0b057af7 278static STDCHAR *
14d89041 279PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
f6c77cf1 280{
14d89041
NIS
281 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
282 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
283 return PerlIOScalar_get_base(aTHX_ f) + s->posn;
284 }
9849c14c 285 return (STDCHAR *) NULL;
f6c77cf1
NIS
286}
287
0b057af7 288static SSize_t
14d89041 289PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
f6c77cf1 290{
14d89041
NIS
291 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
292 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
71edc894 293 STRLEN len;
5a2bc23b 294 (void)SvPV(s->var,len);
696efa16 295 if ((Off_t)len > s->posn)
71edc894 296 return len - (STRLEN)s->posn;
14d89041
NIS
297 else
298 return 0;
299 }
75effbe0 300 return 0;
f6c77cf1
NIS
301}
302
0b057af7 303static Size_t
14d89041 304PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
f6c77cf1 305{
14d89041
NIS
306 if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
307 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
ffe0bb5a 308 SvGETMAGIC(s->var);
14d89041
NIS
309 return SvCUR(s->var);
310 }
311 return 0;
f6c77cf1
NIS
312}
313
0b057af7 314static void
14d89041 315PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
f6c77cf1 316{
14d89041 317 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
71edc894 318 STRLEN len;
c33e8be1 319 PERL_UNUSED_ARG(ptr);
5a2bc23b 320 (void)SvPV(s->var,len);
71edc894 321 s->posn = len - cnt;
f6c77cf1
NIS
322}
323
0b057af7 324static PerlIO *
14d89041
NIS
325PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n,
326 const char *mode, int fd, int imode, int perm,
327 PerlIO * f, int narg, SV ** args)
f6c77cf1 328{
14d89041 329 SV *arg = (narg > 0) ? *args : PerlIOArg;
c33e8be1
Z
330 PERL_UNUSED_ARG(fd);
331 PERL_UNUSED_ARG(imode);
332 PERL_UNUSED_ARG(perm);
14d89041
NIS
333 if (SvROK(arg) || SvPOK(arg)) {
334 if (!f) {
335 f = PerlIO_allocate(aTHX);
336 }
e3feee4e 337 if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
14d89041
NIS
338 PerlIOBase(f)->flags |= PERLIO_F_OPEN;
339 }
340 return f;
341 }
342 return NULL;
f6c77cf1
NIS
343}
344
0b057af7 345static SV *
14d89041 346PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
ecdeb87c 347{
14d89041
NIS
348 PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
349 SV *var = s->var;
350 if (flags & PERLIO_DUP_CLONE)
351 var = PerlIO_sv_dup(aTHX_ var, param);
352 else if (flags & PERLIO_DUP_FD) {
353 /* Equivalent (guesses NI-S) of dup() is to create a new scalar */
354 var = newSVsv(var);
355 }
356 else {
357 var = SvREFCNT_inc(var);
358 }
359 return newRV_noinc(var);
ecdeb87c
NIS
360}
361
0b057af7 362static PerlIO *
14d89041
NIS
363PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
364 int flags)
8cf8f3d1 365{
49b69fb3
FC
366 /* Duplication causes the scalar layer to be pushed on to clone, caus-
367 ing the cloned scalar to be set to the empty string by
368 PerlIOScalar_pushed. So set aside our scalar temporarily. */
369 PerlIOScalar * const os = PerlIOSelf(o, PerlIOScalar);
8380d35a 370 PerlIOScalar *fs = NULL; /* avoid "may be used uninitialized" warning */
49b69fb3
FC
371 SV * const var = os->var;
372 os->var = newSVpvs("");
14d89041 373 if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
7b3cf1c0 374 fs = PerlIOSelf(f, PerlIOScalar);
49b69fb3
FC
375 /* var has been set by implicit push, so replace it */
376 SvREFCNT_dec(fs->var);
14d89041 377 }
49b69fb3
FC
378 SvREFCNT_dec(os->var);
379 os->var = var;
7b3cf1c0
FC
380 if (f) {
381 SV * const rv = PerlIOScalar_arg(aTHX_ o, param, flags);
382 fs->var = SvREFCNT_inc(SvRV(rv));
383 SvREFCNT_dec(rv);
384 fs->posn = os->posn;
385 }
14d89041 386 return f;
8cf8f3d1 387}
f6c77cf1 388
0b057af7 389static PERLIO_FUNCS_DECL(PerlIO_scalar) = {
14d89041
NIS
390 sizeof(PerlIO_funcs),
391 "scalar",
392 sizeof(PerlIOScalar),
393 PERLIO_K_BUFFERED | PERLIO_K_RAW,
394 PerlIOScalar_pushed,
395 PerlIOScalar_popped,
396 PerlIOScalar_open,
397 PerlIOBase_binmode,
398 PerlIOScalar_arg,
399 PerlIOScalar_fileno,
400 PerlIOScalar_dup,
ffe0bb5a 401 PerlIOScalar_read,
3ff3a8b6 402 NULL, /* unread */
14d89041
NIS
403 PerlIOScalar_write,
404 PerlIOScalar_seek,
405 PerlIOScalar_tell,
406 PerlIOScalar_close,
407 PerlIOScalar_flush,
408 PerlIOScalar_fill,
409 PerlIOBase_eof,
410 PerlIOBase_error,
411 PerlIOBase_clearerr,
412 PerlIOBase_setlinebuf,
413 PerlIOScalar_get_base,
414 PerlIOScalar_bufsiz,
415 PerlIOScalar_get_ptr,
416 PerlIOScalar_get_cnt,
417 PerlIOScalar_set_ptrcnt,
f6c77cf1
NIS
418};
419
420
421#endif /* Layers available */
422
e934609f 423MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar
f6c77cf1 424
acf4de66
A
425PROTOTYPES: ENABLE
426
f6c77cf1
NIS
427BOOT:
428{
429#ifdef PERLIO_LAYERS
27da23d5 430 PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
f6c77cf1
NIS
431#endif
432}
433