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) { |
cba44c14 |
26 | if (SvROK(arg)) { |
b35bc0c6 |
27 | if (SvREADONLY(SvRV(arg)) && mode && *mode != 'r') { |
28 | if (ckWARN(WARN_LAYER)) |
76c6a213 |
29 | Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify); |
42bc49da |
30 | SETERRNO(EINVAL, SS_IVCHAN); |
b35bc0c6 |
31 | return -1; |
32 | } |
14d89041 |
33 | s->var = SvREFCNT_inc(SvRV(arg)); |
22ccb26d |
34 | SvGETMAGIC(s->var); |
35 | if (!SvPOK(s->var) && SvOK(s->var)) |
36 | (void)SvPV_nomg_const_nolen(s->var); |
14d89041 |
37 | } |
38 | else { |
39 | s->var = |
40 | SvREFCNT_inc(perl_get_sv |
41 | (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI)); |
42 | } |
564dc057 |
43 | } |
14d89041 |
44 | else { |
45 | s->var = newSVpvn("", 0); |
564dc057 |
46 | } |
c5b94a97 |
47 | SvUPGRADE(s->var, SVt_PV); |
14d89041 |
48 | code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab); |
47cc46ee |
49 | if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE) |
b162af07 |
50 | SvCUR_set(s->var, 0); |
14d89041 |
51 | if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) |
52 | s->posn = SvCUR(s->var); |
53 | else |
54 | s->posn = 0; |
ffe0bb5a |
55 | SvSETMAGIC(s->var); |
14d89041 |
56 | return code; |
f6c77cf1 |
57 | } |
58 | |
59 | IV |
14d89041 |
60 | PerlIOScalar_popped(pTHX_ PerlIO * f) |
f6c77cf1 |
61 | { |
14d89041 |
62 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); |
63 | if (s->var) { |
64 | SvREFCNT_dec(s->var); |
65 | s->var = Nullsv; |
66 | } |
67 | return 0; |
f6c77cf1 |
68 | } |
69 | |
70 | IV |
14d89041 |
71 | PerlIOScalar_close(pTHX_ PerlIO * f) |
f6c77cf1 |
72 | { |
14d89041 |
73 | IV code = PerlIOBase_close(aTHX_ f); |
74 | PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); |
75 | return code; |
f6c77cf1 |
76 | } |
77 | |
78 | IV |
14d89041 |
79 | PerlIOScalar_fileno(pTHX_ PerlIO * f) |
f6c77cf1 |
80 | { |
14d89041 |
81 | return -1; |
f6c77cf1 |
82 | } |
83 | |
84 | IV |
14d89041 |
85 | PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence) |
f6c77cf1 |
86 | { |
14d89041 |
87 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); |
e94207f0 |
88 | STRLEN oldcur; |
42bc49da |
89 | STRLEN newlen; |
e94207f0 |
90 | |
91 | SvGETMAGIC(s->var); |
92 | oldcur = SvCUR(s->var); |
93 | |
14d89041 |
94 | switch (whence) { |
42bc49da |
95 | case SEEK_SET: |
14d89041 |
96 | s->posn = offset; |
97 | break; |
42bc49da |
98 | case SEEK_CUR: |
14d89041 |
99 | s->posn = offset + s->posn; |
100 | break; |
42bc49da |
101 | case SEEK_END: |
14d89041 |
102 | s->posn = offset + SvCUR(s->var); |
103 | break; |
104 | } |
42bc49da |
105 | if (s->posn < 0) { |
106 | if (ckWARN(WARN_LAYER)) |
107 | Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string"); |
108 | SETERRNO(EINVAL, SS_IVCHAN); |
109 | return -1; |
14d89041 |
110 | } |
42bc49da |
111 | newlen = (STRLEN) s->posn; |
112 | if (newlen > oldcur) { |
113 | (void) SvGROW(s->var, newlen); |
114 | Zero(SvPVX(s->var) + oldcur, newlen - oldcur, char); |
115 | /* No SvCUR_set(), though. This is just a seek, not a write. */ |
116 | } |
8b8eea96 |
117 | else if (!SvPVX(s->var)) { |
118 | /* ensure there's always a character buffer */ |
119 | (void)SvGROW(s->var,1); |
120 | } |
42bc49da |
121 | SvPOK_on(s->var); |
14d89041 |
122 | return 0; |
f6c77cf1 |
123 | } |
124 | |
125 | Off_t |
14d89041 |
126 | PerlIOScalar_tell(pTHX_ PerlIO * f) |
f6c77cf1 |
127 | { |
14d89041 |
128 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); |
129 | return s->posn; |
f6c77cf1 |
130 | } |
131 | |
ffe0bb5a |
132 | |
133 | SSize_t |
134 | PerlIOScalar_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) |
135 | { |
136 | if (!f) |
137 | return 0; |
138 | if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) { |
139 | PerlIOBase(f)->flags |= PERLIO_F_ERROR; |
140 | SETERRNO(EBADF, SS_IVCHAN); |
141 | return 0; |
142 | } |
143 | { |
144 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); |
145 | SV *sv = s->var; |
146 | char *p; |
147 | STRLEN len, got; |
148 | p = SvPV(sv, len); |
149 | got = len - (STRLEN)(s->posn); |
150 | if (got <= 0) |
151 | return 0; |
152 | if (got > (STRLEN)count) |
153 | got = (STRLEN)count; |
154 | Copy(p + (STRLEN)(s->posn), vbuf, got, STDCHAR); |
155 | s->posn += (Off_t)got; |
156 | return (SSize_t)got; |
157 | } |
158 | } |
159 | |
f6c77cf1 |
160 | SSize_t |
14d89041 |
161 | PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count) |
f6c77cf1 |
162 | { |
14d89041 |
163 | if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { |
164 | Off_t offset; |
165 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); |
166 | SV *sv = s->var; |
167 | char *dst; |
ffe0bb5a |
168 | SvGETMAGIC(sv); |
14d89041 |
169 | if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) { |
170 | dst = SvGROW(sv, SvCUR(sv) + count); |
171 | offset = SvCUR(sv); |
172 | s->posn = offset + count; |
173 | } |
174 | else { |
175 | if ((s->posn + count) > SvCUR(sv)) |
4a9d6100 |
176 | dst = SvGROW(sv, (STRLEN)s->posn + count); |
14d89041 |
177 | else |
ffe0bb5a |
178 | dst = SvPVX(sv); |
14d89041 |
179 | offset = s->posn; |
180 | s->posn += count; |
181 | } |
182 | Move(vbuf, dst + offset, count, char); |
183 | if ((STRLEN) s->posn > SvCUR(sv)) |
4a9d6100 |
184 | SvCUR_set(sv, (STRLEN)s->posn); |
ffe0bb5a |
185 | SvPOK_on(sv); |
186 | SvSETMAGIC(sv); |
14d89041 |
187 | return count; |
09bf542c |
188 | } |
14d89041 |
189 | else |
190 | return 0; |
f6c77cf1 |
191 | } |
192 | |
193 | IV |
14d89041 |
194 | PerlIOScalar_fill(pTHX_ PerlIO * f) |
f6c77cf1 |
195 | { |
14d89041 |
196 | return -1; |
f6c77cf1 |
197 | } |
198 | |
199 | IV |
14d89041 |
200 | PerlIOScalar_flush(pTHX_ PerlIO * f) |
f6c77cf1 |
201 | { |
14d89041 |
202 | return 0; |
f6c77cf1 |
203 | } |
204 | |
205 | STDCHAR * |
14d89041 |
206 | PerlIOScalar_get_base(pTHX_ PerlIO * f) |
f6c77cf1 |
207 | { |
14d89041 |
208 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); |
209 | if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { |
ffe0bb5a |
210 | SvGETMAGIC(s->var); |
14d89041 |
211 | return (STDCHAR *) SvPV_nolen(s->var); |
212 | } |
9849c14c |
213 | return (STDCHAR *) NULL; |
f6c77cf1 |
214 | } |
215 | |
216 | STDCHAR * |
14d89041 |
217 | PerlIOScalar_get_ptr(pTHX_ PerlIO * f) |
f6c77cf1 |
218 | { |
14d89041 |
219 | if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { |
220 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); |
221 | return PerlIOScalar_get_base(aTHX_ f) + s->posn; |
222 | } |
9849c14c |
223 | return (STDCHAR *) NULL; |
f6c77cf1 |
224 | } |
225 | |
226 | SSize_t |
14d89041 |
227 | PerlIOScalar_get_cnt(pTHX_ PerlIO * f) |
f6c77cf1 |
228 | { |
14d89041 |
229 | if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { |
230 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); |
ffe0bb5a |
231 | SvGETMAGIC(s->var); |
14d89041 |
232 | if (SvCUR(s->var) > (STRLEN) s->posn) |
4a9d6100 |
233 | return SvCUR(s->var) - (STRLEN)s->posn; |
14d89041 |
234 | else |
235 | return 0; |
236 | } |
75effbe0 |
237 | return 0; |
f6c77cf1 |
238 | } |
239 | |
240 | Size_t |
14d89041 |
241 | PerlIOScalar_bufsiz(pTHX_ PerlIO * f) |
f6c77cf1 |
242 | { |
14d89041 |
243 | if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { |
244 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); |
ffe0bb5a |
245 | SvGETMAGIC(s->var); |
14d89041 |
246 | return SvCUR(s->var); |
247 | } |
248 | return 0; |
f6c77cf1 |
249 | } |
250 | |
251 | void |
14d89041 |
252 | PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt) |
f6c77cf1 |
253 | { |
14d89041 |
254 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); |
ffe0bb5a |
255 | SvGETMAGIC(s->var); |
14d89041 |
256 | s->posn = SvCUR(s->var) - cnt; |
f6c77cf1 |
257 | } |
258 | |
259 | PerlIO * |
14d89041 |
260 | PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n, |
261 | const char *mode, int fd, int imode, int perm, |
262 | PerlIO * f, int narg, SV ** args) |
f6c77cf1 |
263 | { |
14d89041 |
264 | SV *arg = (narg > 0) ? *args : PerlIOArg; |
265 | if (SvROK(arg) || SvPOK(arg)) { |
266 | if (!f) { |
267 | f = PerlIO_allocate(aTHX); |
268 | } |
e3feee4e |
269 | if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) { |
14d89041 |
270 | PerlIOBase(f)->flags |= PERLIO_F_OPEN; |
271 | } |
272 | return f; |
273 | } |
274 | return NULL; |
f6c77cf1 |
275 | } |
276 | |
ecdeb87c |
277 | SV * |
14d89041 |
278 | PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags) |
ecdeb87c |
279 | { |
14d89041 |
280 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); |
281 | SV *var = s->var; |
282 | if (flags & PERLIO_DUP_CLONE) |
283 | var = PerlIO_sv_dup(aTHX_ var, param); |
284 | else if (flags & PERLIO_DUP_FD) { |
285 | /* Equivalent (guesses NI-S) of dup() is to create a new scalar */ |
286 | var = newSVsv(var); |
287 | } |
288 | else { |
289 | var = SvREFCNT_inc(var); |
290 | } |
291 | return newRV_noinc(var); |
ecdeb87c |
292 | } |
293 | |
8cf8f3d1 |
294 | PerlIO * |
14d89041 |
295 | PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param, |
296 | int flags) |
8cf8f3d1 |
297 | { |
14d89041 |
298 | if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) { |
299 | PerlIOScalar *fs = PerlIOSelf(f, PerlIOScalar); |
300 | PerlIOScalar *os = PerlIOSelf(o, PerlIOScalar); |
301 | /* var has been set by implicit push */ |
302 | fs->posn = os->posn; |
303 | } |
304 | return f; |
8cf8f3d1 |
305 | } |
f6c77cf1 |
306 | |
27da23d5 |
307 | PERLIO_FUNCS_DECL(PerlIO_scalar) = { |
14d89041 |
308 | sizeof(PerlIO_funcs), |
309 | "scalar", |
310 | sizeof(PerlIOScalar), |
311 | PERLIO_K_BUFFERED | PERLIO_K_RAW, |
312 | PerlIOScalar_pushed, |
313 | PerlIOScalar_popped, |
314 | PerlIOScalar_open, |
315 | PerlIOBase_binmode, |
316 | PerlIOScalar_arg, |
317 | PerlIOScalar_fileno, |
318 | PerlIOScalar_dup, |
ffe0bb5a |
319 | PerlIOScalar_read, |
3ff3a8b6 |
320 | NULL, /* unread */ |
14d89041 |
321 | PerlIOScalar_write, |
322 | PerlIOScalar_seek, |
323 | PerlIOScalar_tell, |
324 | PerlIOScalar_close, |
325 | PerlIOScalar_flush, |
326 | PerlIOScalar_fill, |
327 | PerlIOBase_eof, |
328 | PerlIOBase_error, |
329 | PerlIOBase_clearerr, |
330 | PerlIOBase_setlinebuf, |
331 | PerlIOScalar_get_base, |
332 | PerlIOScalar_bufsiz, |
333 | PerlIOScalar_get_ptr, |
334 | PerlIOScalar_get_cnt, |
335 | PerlIOScalar_set_ptrcnt, |
f6c77cf1 |
336 | }; |
337 | |
338 | |
339 | #endif /* Layers available */ |
340 | |
e934609f |
341 | MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar |
f6c77cf1 |
342 | |
acf4de66 |
343 | PROTOTYPES: ENABLE |
344 | |
f6c77cf1 |
345 | BOOT: |
346 | { |
347 | #ifdef PERLIO_LAYERS |
27da23d5 |
348 | PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar)); |
f6c77cf1 |
349 | #endif |
350 | } |
351 | |