Integrate mainline.
[p5sagit/p5-mst-13.2.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))
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     sv_upgrade(s->var, SVt_PV);
41     code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab);
42     if ((PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE)
43         SvCUR(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, s->posn + count);
109     Move(vbuf, dst + s->posn, count, char);
110     s->posn += count;
111     SvCUR_set(s->var, s->posn);
112     SvPOK_on(s->var);
113     return count;
114 }
115
116 SSize_t
117 PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count)
118 {
119     if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) {
120         Off_t offset;
121         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
122         SV *sv = s->var;
123         char *dst;
124         if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) {
125             dst = SvGROW(sv, SvCUR(sv) + count);
126             offset = SvCUR(sv);
127             s->posn = offset + count;
128         }
129         else {
130             if ((s->posn + count) > SvCUR(sv))
131                 dst = SvGROW(sv, s->posn + count);
132             else
133                 dst = SvPV_nolen(sv);
134             offset = s->posn;
135             s->posn += count;
136         }
137         Move(vbuf, dst + offset, count, char);
138         if ((STRLEN) s->posn > SvCUR(sv))
139             SvCUR_set(sv, s->posn);
140         SvPOK_on(s->var);
141         return count;
142     }
143     else
144         return 0;
145 }
146
147 IV
148 PerlIOScalar_fill(pTHX_ PerlIO * f)
149 {
150     return -1;
151 }
152
153 IV
154 PerlIOScalar_flush(pTHX_ PerlIO * f)
155 {
156     return 0;
157 }
158
159 STDCHAR *
160 PerlIOScalar_get_base(pTHX_ PerlIO * f)
161 {
162     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
163     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
164         return (STDCHAR *) SvPV_nolen(s->var);
165     }
166     return (STDCHAR *) Nullch;
167 }
168
169 STDCHAR *
170 PerlIOScalar_get_ptr(pTHX_ PerlIO * f)
171 {
172     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
173         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
174         return PerlIOScalar_get_base(aTHX_ f) + s->posn;
175     }
176     return (STDCHAR *) Nullch;
177 }
178
179 SSize_t
180 PerlIOScalar_get_cnt(pTHX_ PerlIO * f)
181 {
182     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
183         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
184         if (SvCUR(s->var) > (STRLEN) s->posn)
185             return SvCUR(s->var) - s->posn;
186         else
187             return 0;
188     }
189     return 0;
190 }
191
192 Size_t
193 PerlIOScalar_bufsiz(pTHX_ PerlIO * f)
194 {
195     if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) {
196         PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
197         return SvCUR(s->var);
198     }
199     return 0;
200 }
201
202 void
203 PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt)
204 {
205     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
206     s->posn = SvCUR(s->var) - cnt;
207 }
208
209 PerlIO *
210 PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n,
211                   const char *mode, int fd, int imode, int perm,
212                   PerlIO * f, int narg, SV ** args)
213 {
214     SV *arg = (narg > 0) ? *args : PerlIOArg;
215     if (SvROK(arg) || SvPOK(arg)) {
216         if (!f) {
217             f = PerlIO_allocate(aTHX);
218         }
219         if (f = PerlIO_push(aTHX_ f, self, mode, arg)) {
220             PerlIOBase(f)->flags |= PERLIO_F_OPEN;
221         }
222         return f;
223     }
224     return NULL;
225 }
226
227 SV *
228 PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags)
229 {
230     PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar);
231     SV *var = s->var;
232     if (flags & PERLIO_DUP_CLONE)
233         var = PerlIO_sv_dup(aTHX_ var, param);
234     else if (flags & PERLIO_DUP_FD) {
235         /* Equivalent (guesses NI-S) of dup() is to create a new scalar */
236         var = newSVsv(var);
237     }
238     else {
239         var = SvREFCNT_inc(var);
240     }
241     return newRV_noinc(var);
242 }
243
244 PerlIO *
245 PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param,
246                  int flags)
247 {
248     if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) {
249         PerlIOScalar *fs = PerlIOSelf(f, PerlIOScalar);
250         PerlIOScalar *os = PerlIOSelf(o, PerlIOScalar);
251         /* var has been set by implicit push */
252         fs->posn = os->posn;
253     }
254     return f;
255 }
256
257 PerlIO_funcs PerlIO_scalar = {
258     sizeof(PerlIO_funcs),
259     "scalar",
260     sizeof(PerlIOScalar),
261     PERLIO_K_BUFFERED | PERLIO_K_RAW,
262     PerlIOScalar_pushed,
263     PerlIOScalar_popped,
264     PerlIOScalar_open,
265     PerlIOBase_binmode,
266     PerlIOScalar_arg,
267     PerlIOScalar_fileno,
268     PerlIOScalar_dup,
269     PerlIOBase_read,
270     PerlIOScalar_unread,
271     PerlIOScalar_write,
272     PerlIOScalar_seek,
273     PerlIOScalar_tell,
274     PerlIOScalar_close,
275     PerlIOScalar_flush,
276     PerlIOScalar_fill,
277     PerlIOBase_eof,
278     PerlIOBase_error,
279     PerlIOBase_clearerr,
280     PerlIOBase_setlinebuf,
281     PerlIOScalar_get_base,
282     PerlIOScalar_bufsiz,
283     PerlIOScalar_get_ptr,
284     PerlIOScalar_get_cnt,
285     PerlIOScalar_set_ptrcnt,
286 };
287
288
289 #endif /* Layers available */
290
291 MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar
292
293 PROTOTYPES: ENABLE
294
295 BOOT:
296 {
297 #ifdef PERLIO_LAYERS
298  PerlIO_define_layer(aTHX_ &PerlIO_scalar);
299 #endif
300 }
301