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