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