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