Commit | Line | Data |
f6c77cf1 |
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 | { |
11 | struct _PerlIO base; /* Base "class" info */ |
12 | SV * var; |
13 | Off_t posn; |
14 | } PerlIOScalar; |
15 | |
16 | IV |
17 | PerlIOScalar_pushed(PerlIO *f, const char *mode, SV *arg) |
18 | { |
564dc057 |
19 | dTHX; |
09bf542c |
20 | IV code; |
564dc057 |
21 | PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); |
22 | /* If called (normally) via open() then arg is ref to scalar we are |
23 | using, otherwise arg (from binmode presumably) is either NULL |
24 | or the _name_ of the scalar |
25 | */ |
26 | if (arg) |
27 | { |
28 | if (SvROK(arg)) |
29 | { |
30 | s->var = SvREFCNT_inc(SvRV(arg)); |
31 | } |
32 | else |
33 | { |
34 | s->var = SvREFCNT_inc(perl_get_sv(SvPV_nolen(arg),GV_ADD|GV_ADDMULTI)); |
35 | } |
36 | } |
37 | else |
38 | { |
39 | s->var = newSVpvn("",0); |
40 | } |
41 | sv_upgrade(s->var,SVt_PV); |
09bf542c |
42 | code = PerlIOBase_pushed(f,mode,Nullsv); |
43 | if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) |
c350b88c |
44 | s->posn = SvCUR(SvRV(arg)); |
45 | else |
46 | s->posn = 0; |
ae1204bf |
47 | if ((PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE) |
48 | SvCUR(SvRV(arg)) = 0; |
09bf542c |
49 | return code; |
f6c77cf1 |
50 | } |
51 | |
52 | IV |
53 | PerlIOScalar_popped(PerlIO *f) |
54 | { |
55 | PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); |
56 | if (s->var) |
57 | { |
58 | dTHX; |
59 | SvREFCNT_dec(s->var); |
60 | s->var = Nullsv; |
61 | } |
62 | return 0; |
63 | } |
64 | |
65 | IV |
66 | PerlIOScalar_close(PerlIO *f) |
67 | { |
68 | dTHX; |
69 | IV code = PerlIOBase_close(f); |
f6c77cf1 |
70 | PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF); |
71 | return code; |
72 | } |
73 | |
74 | IV |
75 | PerlIOScalar_fileno(PerlIO *f) |
76 | { |
77 | return -1; |
78 | } |
79 | |
80 | IV |
81 | PerlIOScalar_seek(PerlIO *f, Off_t offset, int whence) |
82 | { |
83 | PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); |
84 | switch(whence) |
85 | { |
86 | case 0: |
87 | s->posn = offset; |
88 | break; |
89 | case 1: |
90 | s->posn = offset + s->posn; |
91 | break; |
92 | case 2: |
93 | s->posn = offset + SvCUR(s->var); |
94 | break; |
95 | } |
96 | if (s->posn > SvCUR(s->var)) |
97 | { |
98 | dTHX; |
99 | (void) SvGROW(s->var,s->posn); |
100 | } |
101 | return 0; |
102 | } |
103 | |
104 | Off_t |
105 | PerlIOScalar_tell(PerlIO *f) |
106 | { |
107 | PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); |
108 | return s->posn; |
109 | } |
110 | |
111 | SSize_t |
112 | PerlIOScalar_unread(PerlIO *f, const void *vbuf, Size_t count) |
113 | { |
114 | dTHX; |
115 | PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); |
116 | char *dst = SvGROW(s->var,s->posn+count); |
773aa825 |
117 | Move(vbuf,dst+s->posn,count,char); |
f6c77cf1 |
118 | s->posn += count; |
119 | SvCUR_set(s->var,s->posn); |
120 | SvPOK_on(s->var); |
121 | return count; |
122 | } |
123 | |
124 | SSize_t |
125 | PerlIOScalar_write(PerlIO *f, const void *vbuf, Size_t count) |
126 | { |
127 | if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) |
128 | { |
09bf542c |
129 | dTHX; |
130 | Off_t offset; |
131 | PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); |
132 | SV *sv = s->var; |
133 | char *dst; |
134 | if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) |
135 | { |
136 | dst = SvGROW(sv,SvCUR(sv)+count); |
137 | offset = SvCUR(sv); |
138 | s->posn = offset+count; |
139 | } |
140 | else |
141 | { |
142 | if ((s->posn+count) > SvCUR(sv)) |
143 | dst = SvGROW(sv,s->posn+count); |
144 | else |
145 | dst = SvPV_nolen(sv); |
146 | offset = s->posn; |
147 | s->posn += count; |
148 | } |
149 | Move(vbuf,dst+offset,count,char); |
150 | if (s->posn > SvCUR(sv)) |
151 | SvCUR_set(sv,s->posn); |
152 | SvPOK_on(s->var); |
153 | return count; |
f6c77cf1 |
154 | } |
09bf542c |
155 | else |
156 | return 0; |
f6c77cf1 |
157 | } |
158 | |
159 | IV |
160 | PerlIOScalar_fill(PerlIO *f) |
161 | { |
162 | return -1; |
163 | } |
164 | |
165 | IV |
166 | PerlIOScalar_flush(PerlIO *f) |
167 | { |
168 | return 0; |
169 | } |
170 | |
171 | STDCHAR * |
172 | PerlIOScalar_get_base(PerlIO *f) |
173 | { |
174 | PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); |
175 | if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) |
176 | { |
177 | dTHX; |
178 | return (STDCHAR *)SvPV_nolen(s->var); |
179 | } |
a144b989 |
180 | return (STDCHAR *) Nullch; |
f6c77cf1 |
181 | } |
182 | |
183 | STDCHAR * |
184 | PerlIOScalar_get_ptr(PerlIO *f) |
185 | { |
186 | if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) |
187 | { |
188 | PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); |
189 | return PerlIOScalar_get_base(f)+s->posn; |
190 | } |
191 | return (STDCHAR *) Nullch; |
192 | } |
193 | |
194 | SSize_t |
195 | PerlIOScalar_get_cnt(PerlIO *f) |
196 | { |
197 | if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) |
198 | { |
199 | PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); |
75effbe0 |
200 | if (SvCUR(s->var) > s->posn) |
201 | return SvCUR(s->var) - s->posn; |
202 | else |
203 | return 0; |
f6c77cf1 |
204 | } |
205 | return 0; |
206 | } |
207 | |
208 | Size_t |
209 | PerlIOScalar_bufsiz(PerlIO *f) |
210 | { |
211 | if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) |
212 | { |
213 | PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); |
214 | return SvCUR(s->var); |
215 | } |
216 | return 0; |
217 | } |
218 | |
219 | void |
220 | PerlIOScalar_set_ptrcnt(PerlIO *f, STDCHAR *ptr, SSize_t cnt) |
221 | { |
222 | PerlIOScalar *s = PerlIOSelf(f,PerlIOScalar); |
223 | s->posn = SvCUR(s->var)-cnt; |
224 | } |
225 | |
226 | PerlIO * |
227 | PerlIOScalar_open(pTHX_ PerlIO_funcs *self, AV *layers, IV n, const char *mode, int fd, int imode, int perm, PerlIO *f, int narg, SV **args) |
228 | { |
229 | PerlIOScalar *s; |
564dc057 |
230 | SV *arg = (narg > 0) ? *args : PerlIOArg; |
231 | if (SvROK(arg) || SvPOK(arg)) |
f6c77cf1 |
232 | { |
564dc057 |
233 | f = PerlIO_allocate(aTHX); |
234 | s = PerlIOSelf(PerlIO_push(aTHX_ f,self,mode,arg),PerlIOScalar); |
235 | PerlIOBase(f)->flags |= PERLIO_F_OPEN; |
236 | return f; |
f6c77cf1 |
237 | } |
238 | return NULL; |
239 | } |
240 | |
241 | |
242 | PerlIO_funcs PerlIO_scalar = { |
243 | "Scalar", |
244 | sizeof(PerlIOScalar), |
245 | PERLIO_K_BUFFERED, |
246 | PerlIOScalar_pushed, |
247 | PerlIOScalar_popped, |
248 | PerlIOScalar_open, |
249 | NULL, |
250 | PerlIOScalar_fileno, |
251 | PerlIOBase_read, |
252 | PerlIOScalar_unread, |
253 | PerlIOScalar_write, |
254 | PerlIOScalar_seek, |
255 | PerlIOScalar_tell, |
256 | PerlIOScalar_close, |
257 | PerlIOScalar_flush, |
258 | PerlIOScalar_fill, |
259 | PerlIOBase_eof, |
260 | PerlIOBase_error, |
261 | PerlIOBase_clearerr, |
262 | PerlIOBase_setlinebuf, |
263 | PerlIOScalar_get_base, |
264 | PerlIOScalar_bufsiz, |
265 | PerlIOScalar_get_ptr, |
266 | PerlIOScalar_get_cnt, |
267 | PerlIOScalar_set_ptrcnt, |
268 | }; |
269 | |
270 | |
271 | #endif /* Layers available */ |
272 | |
273 | MODULE = PerlIO::Scalar PACKAGE = PerlIO::Scalar |
274 | |
acf4de66 |
275 | PROTOTYPES: ENABLE |
276 | |
f6c77cf1 |
277 | BOOT: |
278 | { |
279 | #ifdef PERLIO_LAYERS |
280 | PerlIO_define_layer(aTHX_ &PerlIO_scalar); |
281 | #endif |
282 | } |
283 | |