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