File Coverage

ext/PerlIO-scalar/scalar.xs
Criterion Covered Total %
statement 172 186 92.5
branch n/a
condition n/a
subroutine n/a
total 172 186 92.5


line stmt bran cond sub time code
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            
9           static const char code_point_warning[] =
10           "Strings with code points over 0xFF may not be mapped into in-memory file handles\n";
11            
12           typedef struct {
13           struct _PerlIO base; /* Base "class" info */
14           SV *var;
15           Off_t posn;
16           } PerlIOScalar;
17            
18           IV
19 4390         PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
20           PerlIO_funcs * tab)
21 4386         {
22           IV code;
23 4390         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           */
28 4390         if (arg && SvOK(arg)) {
29 8776         if (SvROK(arg)) {
30 8780         if (SvREADONLY(SvRV(arg)) && !SvIsCOW(SvRV(arg))
31 4398         && mode && *mode != 'r') {
32 4         if (ckWARN(WARN_LAYER))
33 0         Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify);
34 4         SETERRNO(EINVAL, SS_IVCHAN);
35 4         return -1;
36           }
37 8772         s->var = SvREFCNT_inc(SvRV(arg));
38 4394         SvGETMAGIC(s->var);
39 4386         if (!SvPOK(s->var) && SvOK(s->var))
40 12         (void)SvPV_nomg_const_nolen(s->var);
41           }
42           else {
43 0         s->var =
44 0         SvREFCNT_inc(perl_get_sv
45           (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
46           }
47           }
48           else {
49 0         s->var = newSVpvn("", 0);
50           }
51 7998         SvUPGRADE(s->var, SVt_PV);
52 4386         code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
53 4386         if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
54           {
55 3884         sv_force_normal(s->var);
56 3884         SvCUR_set(s->var, 0);
57           }
58 4386         if (SvUTF8(s->var) && !sv_utf8_downgrade(s->var, TRUE)) {
59 4         if (ckWARN(WARN_UTF8))
60 2         Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning);
61 4         SETERRNO(EINVAL, SS_IVCHAN);
62 4         SvREFCNT_dec(s->var);
63 4         s->var = Nullsv;
64 4         return -1;
65           }
66 4382         if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
67           {
68 388         sv_force_normal(s->var);
69 388         s->posn = SvCUR(s->var);
70           }
71           else
72 3994         s->posn = 0;
73 4382         SvSETMAGIC(s->var);
74           return code;
75           }
76            
77           IV
78 4390         PerlIOScalar_popped(pTHX_ PerlIO * f)
79           {
80 4390         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
81 4390         if (s->var) {
82 4382         SvREFCNT_dec(s->var);
83 4382         s->var = Nullsv;
84           }
85 4390         return 0;
86           }
87            
88           IV
89 4386         PerlIOScalar_close(pTHX_ PerlIO * f)
90           {
91 4386         IV code = PerlIOBase_close(aTHX_ f);
92 4386         PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
93 4386         return code;
94           }
95            
96           IV
97 4440         PerlIOScalar_fileno(pTHX_ PerlIO * f)
98           {
99           PERL_UNUSED_ARG(f);
100 4440         return -1;
101           }
102            
103           IV
104 112         PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
105           {
106 112         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
107            
108 112         switch (whence) {
109           case SEEK_SET:
110 98         s->posn = offset;
111 98         break;
112           case SEEK_CUR:
113 6         s->posn = offset + s->posn;
114 6         break;
115           case SEEK_END:
116           {
117           STRLEN oldcur;
118 8         (void)SvPV(s->var, oldcur);
119 8         s->posn = offset + oldcur;
120 8         break;
121           }
122           }
123 112         if (s->posn < 0) {
124 6         if (ckWARN(WARN_LAYER))
125 0         Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
126 6         SETERRNO(EINVAL, SS_IVCHAN);
127 6         return -1;
128           }
129           return 0;
130           }
131            
132           Off_t
133 66         PerlIOScalar_tell(pTHX_ PerlIO * f)
134           {
135 66         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
136 66         return s->posn;
137           }
138            
139            
140           SSize_t
141 148         PerlIOScalar_read(pTHX_ PerlIO *f, void *vbuf, Size_t count)
142           {
143 148         if (!f)
144           return 0;
145 148         if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) {
146 0         PerlIOBase(f)->flags |= PERLIO_F_ERROR;
147 0         SETERRNO(EBADF, SS_IVCHAN);
148 0         return 0;
149           }
150           {
151 148         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
152 148         SV *sv = s->var;
153           char *p;
154           STRLEN len;
155           I32 got;
156 148         p = SvPV(sv, len);
157 148         if (SvUTF8(sv)) {
158 6         if (sv_utf8_downgrade(sv, TRUE)) {
159 2         p = SvPV_nomg(sv, len);
160           }
161           else {
162 4         if (ckWARN(WARN_UTF8))
163 2         Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning);
164 4         SETERRNO(EINVAL, SS_IVCHAN);
165 4         return -1;
166           }
167           }
168 144         got = len - (STRLEN)(s->posn);
169 144         if (got <= 0)
170           return 0;
171 40         if ((STRLEN)got > (STRLEN)count)
172 28         got = (STRLEN)count;
173 40         Copy(p + (STRLEN)(s->posn), vbuf, got, STDCHAR);
174 40         s->posn += (Off_t)got;
175 40         return (SSize_t)got;
176           }
177           }
178            
179           SSize_t
180 79906         PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
181           {
182 159806         if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
183           Off_t offset;
184 79900         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
185 79900         SV *sv = s->var;
186           char *dst;
187 79904         SvGETMAGIC(sv);
188 79900         if (!SvROK(sv)) sv_force_normal(sv);
189 79900         if (SvOK(sv)) SvPV_force_nomg_nolen(sv);
190 79900         if (SvUTF8(sv) && !sv_utf8_downgrade(sv, TRUE)) {
191 4         if (ckWARN(WARN_UTF8))
192 2         Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning);
193 4         SETERRNO(EINVAL, SS_IVCHAN);
194 4         return 0;
195           }
196 79896         if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
197 882         dst = SvGROW(sv, SvCUR(sv) + count + 1);
198 882         offset = SvCUR(sv);
199 882         s->posn = offset + count;
200           }
201           else {
202 79014         STRLEN const cur = SvCUR(sv);
203 79014         if (s->posn > cur) {
204 6         dst = SvGROW(sv, (STRLEN)s->posn + count + 1);
205 6         Zero(SvPVX(sv) + cur, (STRLEN)s->posn - cur, char);
206           }
207 79008         else if ((s->posn + count) >= cur)
208 79002         dst = SvGROW(sv, (STRLEN)s->posn + count + 1);
209           else
210 6         dst = SvPVX(sv);
211 79014         offset = s->posn;
212 79014         s->posn += count;
213           }
214 79896         Move(vbuf, dst + offset, count, char);
215 79896         if ((STRLEN) s->posn > SvCUR(sv)) {
216 79880         SvCUR_set(sv, (STRLEN)s->posn);
217 79880         dst[(STRLEN) s->posn] = 0;
218           }
219 79896         SvPOK_on(sv);
220 79896         SvSETMAGIC(sv);
221 79896         return count;
222           }
223           else
224           return 0;
225           }
226            
227           IV
228 6         PerlIOScalar_fill(pTHX_ PerlIO * f)
229           {
230           PERL_UNUSED_ARG(f);
231 6         return -1;
232           }
233            
234           IV
235 4764         PerlIOScalar_flush(pTHX_ PerlIO * f)
236           {
237           PERL_UNUSED_ARG(f);
238 4764         return 0;
239           }
240            
241           STDCHAR *
242 318         PerlIOScalar_get_base(pTHX_ PerlIO * f)
243           {
244 318         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
245 636         if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
246 322         SvGETMAGIC(s->var);
247 318         return (STDCHAR *) SvPV_nolen(s->var);
248           }
249           return (STDCHAR *) NULL;
250           }
251            
252           STDCHAR *
253 318         PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
254           {
255 318         if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
256 318         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
257 318         return PerlIOScalar_get_base(aTHX_ f) + s->posn;
258           }
259           return (STDCHAR *) NULL;
260           }
261            
262           SSize_t
263 350         PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
264           {
265 700         if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
266 350         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
267           STRLEN len;
268 354         SvGETMAGIC(s->var);
269 350         if (isGV_with_GP(s->var))
270 8         (void)SvPV(s->var,len);
271 342         else len = SvCUR(s->var);
272 350         if (len > (STRLEN) s->posn)
273 196         return len - (STRLEN)s->posn;
274           else
275           return 0;
276           }
277           return 0;
278           }
279            
280           Size_t
281 0         PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
282           {
283 0         if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
284 0         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
285 0         SvGETMAGIC(s->var);
286 0         return SvCUR(s->var);
287           }
288           return 0;
289           }
290            
291           void
292 318         PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
293 318         {
294 318         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
295           STRLEN len;
296           PERL_UNUSED_ARG(ptr);
297 322         SvGETMAGIC(s->var);
298 318         if (isGV_with_GP(s->var)) (void)SvPV(s->var,len);
299 310         else len = SvCUR(s->var);
300 318         s->posn = len - cnt;
301 318         }
302            
303           PerlIO *
304 4386         PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n,
305           const char *mode, int fd, int imode, int perm,
306           PerlIO * f, int narg, SV ** args)
307           {
308 4386         SV *arg = (narg > 0) ? *args : PerlIOArg;
309           PERL_UNUSED_ARG(fd);
310           PERL_UNUSED_ARG(imode);
311           PERL_UNUSED_ARG(perm);
312 4386         if (SvROK(arg) || SvPOK(arg)) {
313 4386         if (!f) {
314 4386         f = PerlIO_allocate(aTHX);
315           }
316 4386         if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
317 4378         PerlIOBase(f)->flags |= PERLIO_F_OPEN;
318           }
319           return f;
320           }
321           return NULL;
322           }
323            
324           SV *
325 8         PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
326           {
327 8         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
328 8         SV *var = s->var;
329 8         if (flags & PERLIO_DUP_CLONE)
330 0         var = PerlIO_sv_dup(aTHX_ var, param);
331 8         else if (flags & PERLIO_DUP_FD) {
332           /* Equivalent (guesses NI-S) of dup() is to create a new scalar */
333 4         var = newSVsv(var);
334           }
335           else {
336           var = SvREFCNT_inc(var);
337           }
338 8         return newRV_noinc(var);
339           }
340            
341           PerlIO *
342 4         PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
343           int flags)
344           {
345           /* Duplication causes the scalar layer to be pushed on to clone, caus-
346           ing the cloned scalar to be set to the empty string by
347           PerlIOScalar_pushed. So set aside our scalar temporarily. */
348 4         PerlIOScalar * const os = PerlIOSelf(o, PerlIOScalar);
349           PerlIOScalar *fs;
350 4         SV * const var = os->var;
351 4         os->var = newSVpvs("");
352 4         if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
353 4         fs = PerlIOSelf(f, PerlIOScalar);
354           /* var has been set by implicit push, so replace it */
355 4         SvREFCNT_dec(fs->var);
356           }
357 4         SvREFCNT_dec(os->var);
358 4         os->var = var;
359 4         if (f) {
360 4         SV * const rv = PerlIOScalar_arg(aTHX_ o, param, flags);
361 8         fs->var = SvREFCNT_inc(SvRV(rv));
362 4         SvREFCNT_dec(rv);
363 4         fs->posn = os->posn;
364           }
365 4         return f;
366           }
367            
368           PERLIO_FUNCS_DECL(PerlIO_scalar) = {
369           sizeof(PerlIO_funcs),
370           "scalar",
371           sizeof(PerlIOScalar),
372           PERLIO_K_BUFFERED | PERLIO_K_RAW,
373           PerlIOScalar_pushed,
374           PerlIOScalar_popped,
375           PerlIOScalar_open,
376           PerlIOBase_binmode,
377           PerlIOScalar_arg,
378           PerlIOScalar_fileno,
379           PerlIOScalar_dup,
380           PerlIOScalar_read,
381           NULL, /* unread */
382           PerlIOScalar_write,
383           PerlIOScalar_seek,
384           PerlIOScalar_tell,
385           PerlIOScalar_close,
386           PerlIOScalar_flush,
387           PerlIOScalar_fill,
388           PerlIOBase_eof,
389           PerlIOBase_error,
390           PerlIOBase_clearerr,
391           PerlIOBase_setlinebuf,
392           PerlIOScalar_get_base,
393           PerlIOScalar_bufsiz,
394           PerlIOScalar_get_ptr,
395           PerlIOScalar_get_cnt,
396           PerlIOScalar_set_ptrcnt,
397           };
398            
399            
400           #endif /* Layers available */
401            
402           MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar
403            
404           PROTOTYPES: ENABLE
405            
406           BOOT:
407           {
408           #ifdef PERLIO_LAYERS
409 130         PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
410           #endif
411           }
412