This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
eec2de9e7fd158d941e4fe01d5ab30a92d67a503
[perl5.git] / ext / PerlIO-scalar / scalar.xs
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 PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg,
20                     PerlIO_funcs * tab)
21 {
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      */
28     if (arg && SvOK(arg)) {
29         if (SvROK(arg)) {
30             if (SvREADONLY(SvRV(arg)) && !SvIsCOW(SvRV(arg))
31              && mode && *mode != 'r') {
32                 if (ckWARN(WARN_LAYER))
33                     Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify);
34                 SETERRNO(EINVAL, SS_IVCHAN);
35                 return -1;
36             }
37             s->var = SvREFCNT_inc(SvRV(arg));
38             SvGETMAGIC(s->var);
39             if (!SvPOK(s->var) && SvOK(s->var))
40                 (void)SvPV_nomg_const_nolen(s->var);
41         }
42         else {
43             s->var =
44                 SvREFCNT_inc(perl_get_sv
45                              (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
46         }
47     }
48     else {
49         s->var = newSVpvs("");
50     }
51     SvUPGRADE(s->var, SVt_PV);
52
53     code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
54     if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
55     {
56         sv_force_normal(s->var);
57         SvCUR_set(s->var, 0);
58         if (SvPOK(s->var)) *SvPVX(s->var) = 0;
59     }
60     if (SvUTF8(s->var) && !sv_utf8_downgrade(s->var, TRUE)) {
61         if (ckWARN(WARN_UTF8))
62             Perl_warner(aTHX_ packWARN(WARN_UTF8), code_point_warning);
63         SETERRNO(EINVAL, SS_IVCHAN);
64         SvREFCNT_dec(s->var);
65         s->var = Nullsv;
66         return -1;
67     }
68     if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
69         s->posn = SvOK(s->var) ? sv_len(s->var) : 0;
70     else
71         s->posn = 0;
72     SvSETMAGIC(s->var);
73     return code;
74 }
75
76 IV
77 PerlIOScalar_popped(pTHX_ PerlIO * f)
78 {
79     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
80     if (s->var) {
81         SvREFCNT_dec(s->var);
82         s->var = Nullsv;
83     }
84     return 0;
85 }
86
87 IV
88 PerlIOScalar_close(pTHX_ PerlIO * f)
89 {
90     IV code = PerlIOBase_close(aTHX_ f);
91     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
92     return code;
93 }
94
95 IV
96 PerlIOScalar_fileno(pTHX_ PerlIO * f)
97 {
98     PERL_UNUSED_ARG(f);
99     return -1;
100 }
101
102 IV
103 PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
104 {
105     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
106     Off_t new_posn;
107
108     switch (whence) {
109     case SEEK_SET:
110         new_posn = offset;
111         break;
112     case SEEK_CUR:
113         new_posn = offset + s->posn;
114         break;
115     case SEEK_END:
116       {
117         STRLEN oldcur;
118         (void)SvPV(s->var, oldcur);
119         new_posn = offset + oldcur;
120         break;
121       }
122     default:
123         SETERRNO(EINVAL, SS_IVCHAN);
124         return -1;
125     }
126     if (new_posn < 0) {
127         if (ckWARN(WARN_LAYER))
128             Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string");
129         SETERRNO(EINVAL, SS_IVCHAN);
130         return -1;
131     }
132     s->posn = new_posn;
133     return 0;
134 }
135
136 Off_t
137 PerlIOScalar_tell(pTHX_ PerlIO * f)
138 {
139     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
140     return s->posn;
141 }
142
143
144 SSize_t
145 PerlIOScalar_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);
152         Perl_PerlIO_save_errno(aTHX_ f);
153         return 0;
154     }
155     {
156         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
157         SV *sv = s->var;
158         char *p;
159         STRLEN len;
160         STRLEN got;
161         p = SvPV(sv, len);
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         }
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)
180             return 0;
181         got = len - (STRLEN)(s->posn);
182         if ((STRLEN)got > (STRLEN)count)
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
190 SSize_t
191 PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
192 {
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;
198         SvGETMAGIC(sv);
199         if (!SvROK(sv)) sv_force_normal(sv);
200         if (SvOK(sv)) SvPV_force_nomg_nolen(sv);
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         }
207         if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
208             dst = SvGROW(sv, SvCUR(sv) + count + 1);
209             offset = SvCUR(sv);
210             s->posn = offset + count;
211         }
212         else {
213             STRLEN const cur = SvCUR(sv);
214
215             /* ensure we don't try to create ridiculously large
216              * SVs on small platforms
217              */
218 #if SSize_t_size < Off_t_size
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
229             if ((STRLEN)s->posn > cur) {
230                 dst = SvGROW(sv, (STRLEN)s->posn + count + 1);
231                 Zero(SvPVX(sv) + cur, (STRLEN)s->posn - cur, char);
232             }
233             else if ((s->posn + count) >= cur)
234                 dst = SvGROW(sv, (STRLEN)s->posn + count + 1);
235             else
236                 dst = SvPVX(sv);
237             offset = s->posn;
238             s->posn += count;
239         }
240         Move(vbuf, dst + offset, count, char);
241         if ((STRLEN) s->posn > SvCUR(sv)) {
242             SvCUR_set(sv, (STRLEN)s->posn);
243             dst[(STRLEN) s->posn] = 0;
244         }
245         SvPOK_on(sv);
246         SvSETMAGIC(sv);
247         return count;
248     }
249     else
250         return 0;
251 }
252
253 IV
254 PerlIOScalar_fill(pTHX_ PerlIO * f)
255 {
256     PERL_UNUSED_ARG(f);
257     return -1;
258 }
259
260 IV
261 PerlIOScalar_flush(pTHX_ PerlIO * f)
262 {
263     PERL_UNUSED_ARG(f);
264     return 0;
265 }
266
267 STDCHAR *
268 PerlIOScalar_get_base(pTHX_ PerlIO * f)
269 {
270     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
271     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
272         SvGETMAGIC(s->var);
273         return (STDCHAR *) SvPV_nolen(s->var);
274     }
275     return (STDCHAR *) NULL;
276 }
277
278 STDCHAR *
279 PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
280 {
281     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
282         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
283         return PerlIOScalar_get_base(aTHX_ f) + s->posn;
284     }
285     return (STDCHAR *) NULL;
286 }
287
288 SSize_t
289 PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
290 {
291     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
292         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
293         STRLEN len;
294         (void)SvPV(s->var,len);
295         if ((Off_t)len > s->posn)
296             return len - (STRLEN)s->posn;
297         else
298             return 0;
299     }
300     return 0;
301 }
302
303 Size_t
304 PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
305 {
306     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
307         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
308         SvGETMAGIC(s->var);
309         return SvCUR(s->var);
310     }
311     return 0;
312 }
313
314 void
315 PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
316 {
317     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
318     STRLEN len;
319     PERL_UNUSED_ARG(ptr);
320     (void)SvPV(s->var,len);
321     s->posn = len - cnt;
322 }
323
324 PerlIO *
325 PerlIOScalar_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)
328 {
329     SV *arg = (narg > 0) ? *args : PerlIOArg;
330     PERL_UNUSED_ARG(fd);
331     PERL_UNUSED_ARG(imode);
332     PERL_UNUSED_ARG(perm);
333     if (SvROK(arg) || SvPOK(arg)) {
334         if (!f) {
335             f = PerlIO_allocate(aTHX);
336         }
337         if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
338             PerlIOBase(f)->flags |= PERLIO_F_OPEN;
339         }
340         return f;
341     }
342     return NULL;
343 }
344
345 SV *
346 PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
347 {
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);
360 }
361
362 PerlIO *
363 PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
364                  int flags)
365 {
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);
370     PerlIOScalar *fs = NULL; /* avoid "may be used uninitialized" warning */
371     SV * const var = os->var;
372     os->var = newSVpvs("");
373     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
374         fs = PerlIOSelf(f, PerlIOScalar);
375         /* var has been set by implicit push, so replace it */
376         SvREFCNT_dec(fs->var);
377     }
378     SvREFCNT_dec(os->var);
379     os->var = var;
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     }
386     return f;
387 }
388
389 PERLIO_FUNCS_DECL(PerlIO_scalar) = {
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,
401     PerlIOScalar_read,
402     NULL, /* unread */
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,
418 };
419
420
421 #endif /* Layers available */
422
423 MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar
424
425 PROTOTYPES: ENABLE
426
427 BOOT:
428 {
429 #ifdef PERLIO_LAYERS
430  PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
431 #endif
432 }
433