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