Commit | Line | Data |
---|---|---|
f6c77cf1 NIS |
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 NIS |
9 | typedef struct { |
10 | struct _PerlIO base; /* Base "class" info */ | |
11 | SV *var; | |
12 | Off_t posn; | |
f6c77cf1 NIS |
13 | } PerlIOScalar; |
14 | ||
15 | IV | |
14d89041 NIS |
16 | PerlIOScalar_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, |
17 | PerlIO_funcs * tab) | |
f6c77cf1 | 18 | { |
14d89041 NIS |
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)); | |
5b7ea690 JH |
28 | if (!SvPOK(s->var)) |
29 | (void)SvPV_nolen(s->var); | |
14d89041 NIS |
30 | } |
31 | else { | |
32 | s->var = | |
33 | SvREFCNT_inc(perl_get_sv | |
34 | (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI)); | |
35 | } | |
564dc057 | 36 | } |
14d89041 NIS |
37 | else { |
38 | s->var = newSVpvn("", 0); | |
564dc057 | 39 | } |
14d89041 NIS |
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; | |
f6c77cf1 NIS |
49 | } |
50 | ||
51 | IV | |
14d89041 | 52 | PerlIOScalar_popped(pTHX_ PerlIO * f) |
f6c77cf1 | 53 | { |
14d89041 NIS |
54 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); |
55 | if (s->var) { | |
56 | SvREFCNT_dec(s->var); | |
57 | s->var = Nullsv; | |
58 | } | |
59 | return 0; | |
f6c77cf1 NIS |
60 | } |
61 | ||
62 | IV | |
14d89041 | 63 | PerlIOScalar_close(pTHX_ PerlIO * f) |
f6c77cf1 | 64 | { |
14d89041 NIS |
65 | IV code = PerlIOBase_close(aTHX_ f); |
66 | PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); | |
67 | return code; | |
f6c77cf1 NIS |
68 | } |
69 | ||
70 | IV | |
14d89041 | 71 | PerlIOScalar_fileno(pTHX_ PerlIO * f) |
f6c77cf1 | 72 | { |
14d89041 | 73 | return -1; |
f6c77cf1 NIS |
74 | } |
75 | ||
76 | IV | |
14d89041 | 77 | PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence) |
f6c77cf1 | 78 | { |
14d89041 NIS |
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; | |
f6c77cf1 NIS |
95 | } |
96 | ||
97 | Off_t | |
14d89041 | 98 | PerlIOScalar_tell(pTHX_ PerlIO * f) |
f6c77cf1 | 99 | { |
14d89041 NIS |
100 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); |
101 | return s->posn; | |
f6c77cf1 NIS |
102 | } |
103 | ||
104 | SSize_t | |
14d89041 | 105 | PerlIOScalar_unread(pTHX_ PerlIO * f, const void *vbuf, Size_t count) |
f6c77cf1 | 106 | { |
14d89041 NIS |
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; | |
f6c77cf1 NIS |
114 | } |
115 | ||
116 | SSize_t | |
14d89041 | 117 | PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count) |
f6c77cf1 | 118 | { |
14d89041 NIS |
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; | |
09bf542c | 142 | } |
14d89041 NIS |
143 | else |
144 | return 0; | |
f6c77cf1 NIS |
145 | } |
146 | ||
147 | IV | |
14d89041 | 148 | PerlIOScalar_fill(pTHX_ PerlIO * f) |
f6c77cf1 | 149 | { |
14d89041 | 150 | return -1; |
f6c77cf1 NIS |
151 | } |
152 | ||
153 | IV | |
14d89041 | 154 | PerlIOScalar_flush(pTHX_ PerlIO * f) |
f6c77cf1 | 155 | { |
14d89041 | 156 | return 0; |
f6c77cf1 NIS |
157 | } |
158 | ||
159 | STDCHAR * | |
14d89041 | 160 | PerlIOScalar_get_base(pTHX_ PerlIO * f) |
f6c77cf1 | 161 | { |
14d89041 NIS |
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; | |
f6c77cf1 NIS |
167 | } |
168 | ||
169 | STDCHAR * | |
14d89041 | 170 | PerlIOScalar_get_ptr(pTHX_ PerlIO * f) |
f6c77cf1 | 171 | { |
14d89041 NIS |
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; | |
f6c77cf1 NIS |
177 | } |
178 | ||
179 | SSize_t | |
14d89041 | 180 | PerlIOScalar_get_cnt(pTHX_ PerlIO * f) |
f6c77cf1 | 181 | { |
14d89041 NIS |
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 | } | |
75effbe0 | 189 | return 0; |
f6c77cf1 NIS |
190 | } |
191 | ||
192 | Size_t | |
14d89041 | 193 | PerlIOScalar_bufsiz(pTHX_ PerlIO * f) |
f6c77cf1 | 194 | { |
14d89041 NIS |
195 | if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { |
196 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); | |
197 | return SvCUR(s->var); | |
198 | } | |
199 | return 0; | |
f6c77cf1 NIS |
200 | } |
201 | ||
202 | void | |
14d89041 | 203 | PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt) |
f6c77cf1 | 204 | { |
14d89041 NIS |
205 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); |
206 | s->posn = SvCUR(s->var) - cnt; | |
f6c77cf1 NIS |
207 | } |
208 | ||
209 | PerlIO * | |
14d89041 NIS |
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) | |
f6c77cf1 | 213 | { |
14d89041 NIS |
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; | |
f6c77cf1 NIS |
225 | } |
226 | ||
ecdeb87c | 227 | SV * |
14d89041 | 228 | PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags) |
ecdeb87c | 229 | { |
14d89041 NIS |
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); | |
ecdeb87c NIS |
242 | } |
243 | ||
8cf8f3d1 | 244 | PerlIO * |
14d89041 NIS |
245 | PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param, |
246 | int flags) | |
8cf8f3d1 | 247 | { |
14d89041 NIS |
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; | |
8cf8f3d1 | 255 | } |
f6c77cf1 NIS |
256 | |
257 | PerlIO_funcs PerlIO_scalar = { | |
14d89041 NIS |
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, | |
f6c77cf1 NIS |
286 | }; |
287 | ||
288 | ||
289 | #endif /* Layers available */ | |
290 | ||
e934609f | 291 | MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar |
f6c77cf1 | 292 | |
acf4de66 A |
293 | PROTOTYPES: ENABLE |
294 | ||
f6c77cf1 NIS |
295 | BOOT: |
296 | { | |
297 | #ifdef PERLIO_LAYERS | |
298 | PerlIO_define_layer(aTHX_ &PerlIO_scalar); | |
299 | #endif | |
300 | } | |
301 |