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