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