This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
160deb2191d16811dcc1dfd5e2b403000b5632c2
[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             s->var = SvREFCNT_inc(SvRV(arg));
28             if (!SvPOK(s->var) && SvTYPE(SvRV(arg)) > SVt_NULL)
29                 (void)SvPV_nolen(s->var);
30         }
31         else {
32             s->var =
33                 SvREFCNT_inc(perl_get_sv
34                              (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI));
35         }
36     }
37     else {
38         s->var = newSVpvn("", 0);
39     }
40     SvUPGRADE(s->var, SVt_PV);
41     code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
42     if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
43         SvCUR_set(s->var, 0);
44     if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND)
45         s->posn = SvCUR(s->var);
46     else
47         s->posn = 0;
48     return code;
49 }
50
51 IV
52 PerlIOScalar_popped(pTHX_ PerlIO * f)
53 {
54     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
55     if (s->var) {
56         SvREFCNT_dec(s->var);
57         s->var = Nullsv;
58     }
59     return 0;
60 }
61
62 IV
63 PerlIOScalar_close(pTHX_ PerlIO * f)
64 {
65     IV code = PerlIOBase_close(aTHX_ f);
66     PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF);
67     return code;
68 }
69
70 IV
71 PerlIOScalar_fileno(pTHX_ PerlIO * f)
72 {
73     return -1;
74 }
75
76 IV
77 PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence)
78 {
79     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
80     switch (whence) {
81     case 0:
82         s->posn = offset;
83         break;
84     case 1:
85         s->posn = offset + s->posn;
86         break;
87     case 2:
88         s->posn = offset + SvCUR(s->var);
89         break;
90     }
91     if ((STRLEN) s->posn > SvCUR(s->var)) {
92         (void) SvGROW(s->var, (STRLEN) s->posn);
93     }
94     return 0;
95 }
96
97 Off_t
98 PerlIOScalar_tell(pTHX_ PerlIO * f)
99 {
100     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
101     return s->posn;
102 }
103
104 SSize_t
105 PerlIOScalar_unread(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
106 {
107     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
108     char *dst = SvGROW(s->var, (STRLEN)s->posn + count);
109     s->posn -= count;
110     Move(vbuf, dst + s->posn, count, char);
111     SvPOK_on(s->var);
112     return count;
113 }
114
115 SSize_t
116 PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
117 {
118     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
119         Off_t offset;
120         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
121         SV *sv = s->var;
122         char *dst;
123         if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
124             dst = SvGROW(sv, SvCUR(sv) + count);
125             offset = SvCUR(sv);
126             s->posn = offset + count;
127         }
128         else {
129             if ((s->posn + count) > SvCUR(sv))
130                 dst = SvGROW(sv, (STRLEN)s->posn + count);
131             else
132                 dst = SvPV_nolen(sv);
133             offset = s->posn;
134             s->posn += count;
135         }
136         Move(vbuf, dst + offset, count, char);
137         if ((STRLEN) s->posn > SvCUR(sv))
138             SvCUR_set(sv, (STRLEN)s->posn);
139         SvPOK_on(s->var);
140         return count;
141     }
142     else
143         return 0;
144 }
145
146 IV
147 PerlIOScalar_fill(pTHX_ PerlIO * f)
148 {
149     return -1;
150 }
151
152 IV
153 PerlIOScalar_flush(pTHX_ PerlIO * f)
154 {
155     return 0;
156 }
157
158 STDCHAR *
159 PerlIOScalar_get_base(pTHX_ PerlIO * f)
160 {
161     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
162     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
163         return (STDCHAR *) SvPV_nolen(s->var);
164     }
165     return (STDCHAR *) Nullch;
166 }
167
168 STDCHAR *
169 PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
170 {
171     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
172         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
173         return PerlIOScalar_get_base(aTHX_ f) + s->posn;
174     }
175     return (STDCHAR *) Nullch;
176 }
177
178 SSize_t
179 PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
180 {
181     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
182         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
183         if (SvCUR(s->var) > (STRLEN) s->posn)
184             return SvCUR(s->var) - (STRLEN)s->posn;
185         else
186             return 0;
187     }
188     return 0;
189 }
190
191 Size_t
192 PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
193 {
194     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
195         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
196         return SvCUR(s->var);
197     }
198     return 0;
199 }
200
201 void
202 PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
203 {
204     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
205     s->posn = SvCUR(s->var) - cnt;
206 }
207
208 PerlIO *
209 PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n,
210                   const char *mode, int fd, int imode, int perm,
211                   PerlIO * f, int narg, SV ** args)
212 {
213     SV *arg = (narg > 0) ? *args : PerlIOArg;
214     if (SvROK(arg) || SvPOK(arg)) {
215         if (!f) {
216             f = PerlIO_allocate(aTHX);
217         }
218         if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) {
219             PerlIOBase(f)->flags |= PERLIO_F_OPEN;
220         }
221         return f;
222     }
223     return NULL;
224 }
225
226 SV *
227 PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
228 {
229     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
230     SV *var = s->var;
231     if (flags & PERLIO_DUP_CLONE)
232         var = PerlIO_sv_dup(aTHX_ var, param);
233     else if (flags & PERLIO_DUP_FD) {
234         /* Equivalent (guesses NI-S) of dup() is to create a new scalar */
235         var = newSVsv(var);
236     }
237     else {
238         var = SvREFCNT_inc(var);
239     }
240     return newRV_noinc(var);
241 }
242
243 PerlIO *
244 PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
245                  int flags)
246 {
247     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
248         PerlIOScalar *fs = PerlIOSelf(f, PerlIOScalar);
249         PerlIOScalar *os = PerlIOSelf(o, PerlIOScalar);
250         /* var has been set by implicit push */
251         fs->posn = os->posn;
252     }
253     return f;
254 }
255
256 PERLIO_FUNCS_DECL(PerlIO_scalar) = {
257     sizeof(PerlIO_funcs),
258     "scalar",
259     sizeof(PerlIOScalar),
260     PERLIO_K_BUFFERED | PERLIO_K_RAW,
261     PerlIOScalar_pushed,
262     PerlIOScalar_popped,
263     PerlIOScalar_open,
264     PerlIOBase_binmode,
265     PerlIOScalar_arg,
266     PerlIOScalar_fileno,
267     PerlIOScalar_dup,
268     PerlIOBase_read,
269     PerlIOScalar_unread,
270     PerlIOScalar_write,
271     PerlIOScalar_seek,
272     PerlIOScalar_tell,
273     PerlIOScalar_close,
274     PerlIOScalar_flush,
275     PerlIOScalar_fill,
276     PerlIOBase_eof,
277     PerlIOBase_error,
278     PerlIOBase_clearerr,
279     PerlIOBase_setlinebuf,
280     PerlIOScalar_get_base,
281     PerlIOScalar_bufsiz,
282     PerlIOScalar_get_ptr,
283     PerlIOScalar_get_cnt,
284     PerlIOScalar_set_ptrcnt,
285 };
286
287
288 #endif /* Layers available */
289
290 MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar
291
292 PROTOTYPES: ENABLE
293
294 BOOT:
295 {
296 #ifdef PERLIO_LAYERS
297  PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar));
298 #endif
299 }
300