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 | */ | |
82505891 | 25 | if (arg && SvOK(arg)) { |
cba44c14 | 26 | if (SvROK(arg)) { |
47d6f3d6 FC |
27 | if (SvREADONLY(SvRV(arg)) && !SvIsCOW(SvRV(arg)) |
28 | && mode && *mode != 'r') { | |
b35bc0c6 | 29 | if (ckWARN(WARN_LAYER)) |
76c6a213 | 30 | Perl_warner(aTHX_ packWARN(WARN_LAYER), "%s", PL_no_modify); |
42bc49da | 31 | SETERRNO(EINVAL, SS_IVCHAN); |
b35bc0c6 RGS |
32 | return -1; |
33 | } | |
14d89041 | 34 | s->var = SvREFCNT_inc(SvRV(arg)); |
22ccb26d BM |
35 | SvGETMAGIC(s->var); |
36 | if (!SvPOK(s->var) && SvOK(s->var)) | |
37 | (void)SvPV_nomg_const_nolen(s->var); | |
14d89041 NIS |
38 | } |
39 | else { | |
40 | s->var = | |
41 | SvREFCNT_inc(perl_get_sv | |
42 | (SvPV_nolen(arg), GV_ADD | GV_ADDMULTI)); | |
43 | } | |
564dc057 | 44 | } |
14d89041 NIS |
45 | else { |
46 | s->var = newSVpvn("", 0); | |
564dc057 | 47 | } |
c5b94a97 | 48 | SvUPGRADE(s->var, SVt_PV); |
14d89041 | 49 | code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab); |
47cc46ee | 50 | if (!SvOK(s->var) || (PerlIOBase(f)->flags) & PERLIO_F_TRUNCATE) |
526fd1b4 FC |
51 | { |
52 | sv_force_normal(s->var); | |
b162af07 | 53 | SvCUR_set(s->var, 0); |
526fd1b4 | 54 | } |
14d89041 | 55 | if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) |
526fd1b4 FC |
56 | { |
57 | sv_force_normal(s->var); | |
14d89041 | 58 | s->posn = SvCUR(s->var); |
526fd1b4 | 59 | } |
14d89041 NIS |
60 | else |
61 | s->posn = 0; | |
ffe0bb5a | 62 | SvSETMAGIC(s->var); |
14d89041 | 63 | return code; |
f6c77cf1 NIS |
64 | } |
65 | ||
66 | IV | |
14d89041 | 67 | PerlIOScalar_popped(pTHX_ PerlIO * f) |
f6c77cf1 | 68 | { |
14d89041 NIS |
69 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); |
70 | if (s->var) { | |
71 | SvREFCNT_dec(s->var); | |
72 | s->var = Nullsv; | |
73 | } | |
74 | return 0; | |
f6c77cf1 NIS |
75 | } |
76 | ||
77 | IV | |
14d89041 | 78 | PerlIOScalar_close(pTHX_ PerlIO * f) |
f6c77cf1 | 79 | { |
14d89041 NIS |
80 | IV code = PerlIOBase_close(aTHX_ f); |
81 | PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); | |
82 | return code; | |
f6c77cf1 NIS |
83 | } |
84 | ||
85 | IV | |
14d89041 | 86 | PerlIOScalar_fileno(pTHX_ PerlIO * f) |
f6c77cf1 | 87 | { |
c33e8be1 | 88 | PERL_UNUSED_ARG(f); |
14d89041 | 89 | return -1; |
f6c77cf1 NIS |
90 | } |
91 | ||
92 | IV | |
14d89041 | 93 | PerlIOScalar_seek(pTHX_ PerlIO * f, Off_t offset, int whence) |
f6c77cf1 | 94 | { |
14d89041 | 95 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); |
e94207f0 | 96 | |
14d89041 | 97 | switch (whence) { |
42bc49da | 98 | case SEEK_SET: |
14d89041 NIS |
99 | s->posn = offset; |
100 | break; | |
42bc49da | 101 | case SEEK_CUR: |
14d89041 NIS |
102 | s->posn = offset + s->posn; |
103 | break; | |
42bc49da | 104 | case SEEK_END: |
b6597275 FC |
105 | { |
106 | STRLEN oldcur; | |
107 | (void)SvPV(s->var, oldcur); | |
108 | s->posn = offset + oldcur; | |
14d89041 | 109 | break; |
b6597275 | 110 | } |
14d89041 | 111 | } |
42bc49da JH |
112 | if (s->posn < 0) { |
113 | if (ckWARN(WARN_LAYER)) | |
114 | Perl_warner(aTHX_ packWARN(WARN_LAYER), "Offset outside string"); | |
115 | SETERRNO(EINVAL, SS_IVCHAN); | |
116 | return -1; | |
14d89041 NIS |
117 | } |
118 | return 0; | |
f6c77cf1 NIS |
119 | } |
120 | ||
121 | Off_t | |
14d89041 | 122 | PerlIOScalar_tell(pTHX_ PerlIO * f) |
f6c77cf1 | 123 | { |
14d89041 NIS |
124 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); |
125 | return s->posn; | |
f6c77cf1 NIS |
126 | } |
127 | ||
ffe0bb5a DM |
128 | |
129 | SSize_t | |
130 | PerlIOScalar_read(pTHX_ PerlIO *f, void *vbuf, Size_t count) | |
131 | { | |
132 | if (!f) | |
133 | return 0; | |
134 | if (!(PerlIOBase(f)->flags & PERLIO_F_CANREAD)) { | |
135 | PerlIOBase(f)->flags |= PERLIO_F_ERROR; | |
136 | SETERRNO(EBADF, SS_IVCHAN); | |
137 | return 0; | |
138 | } | |
139 | { | |
140 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); | |
141 | SV *sv = s->var; | |
142 | char *p; | |
ab9f1586 FC |
143 | STRLEN len; |
144 | I32 got; | |
ffe0bb5a DM |
145 | p = SvPV(sv, len); |
146 | got = len - (STRLEN)(s->posn); | |
147 | if (got <= 0) | |
148 | return 0; | |
c33e8be1 | 149 | if ((STRLEN)got > (STRLEN)count) |
ffe0bb5a DM |
150 | got = (STRLEN)count; |
151 | Copy(p + (STRLEN)(s->posn), vbuf, got, STDCHAR); | |
152 | s->posn += (Off_t)got; | |
153 | return (SSize_t)got; | |
154 | } | |
155 | } | |
156 | ||
f6c77cf1 | 157 | SSize_t |
14d89041 | 158 | PerlIOScalar_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count) |
f6c77cf1 | 159 | { |
14d89041 NIS |
160 | if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { |
161 | Off_t offset; | |
162 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); | |
163 | SV *sv = s->var; | |
164 | char *dst; | |
ffe0bb5a | 165 | SvGETMAGIC(sv); |
c5a04db8 FC |
166 | if (!SvROK(sv)) sv_force_normal(sv); |
167 | if (SvOK(sv)) SvPV_force_nomg_nolen(sv); | |
14d89041 | 168 | if ((PerlIOBase(f)->flags) & PERLIO_F_APPEND) { |
8af88444 | 169 | dst = SvGROW(sv, SvCUR(sv) + count + 1); |
14d89041 NIS |
170 | offset = SvCUR(sv); |
171 | s->posn = offset + count; | |
172 | } | |
173 | else { | |
b6597275 FC |
174 | STRLEN const cur = SvCUR(sv); |
175 | if (s->posn > cur) { | |
8af88444 | 176 | dst = SvGROW(sv, (STRLEN)s->posn + count + 1); |
b6597275 FC |
177 | Zero(SvPVX(sv) + cur, (STRLEN)s->posn - cur, char); |
178 | } | |
8af88444 BL |
179 | else if ((s->posn + count) >= cur) |
180 | dst = SvGROW(sv, (STRLEN)s->posn + count + 1); | |
14d89041 | 181 | else |
ffe0bb5a | 182 | dst = SvPVX(sv); |
14d89041 NIS |
183 | offset = s->posn; |
184 | s->posn += count; | |
185 | } | |
186 | Move(vbuf, dst + offset, count, char); | |
8af88444 | 187 | if ((STRLEN) s->posn > SvCUR(sv)) { |
4a9d6100 | 188 | SvCUR_set(sv, (STRLEN)s->posn); |
8af88444 BL |
189 | dst[(STRLEN) s->posn] = 0; |
190 | } | |
ffe0bb5a DM |
191 | SvPOK_on(sv); |
192 | SvSETMAGIC(sv); | |
14d89041 | 193 | return count; |
09bf542c | 194 | } |
14d89041 NIS |
195 | else |
196 | return 0; | |
f6c77cf1 NIS |
197 | } |
198 | ||
199 | IV | |
14d89041 | 200 | PerlIOScalar_fill(pTHX_ PerlIO * f) |
f6c77cf1 | 201 | { |
c33e8be1 | 202 | PERL_UNUSED_ARG(f); |
14d89041 | 203 | return -1; |
f6c77cf1 NIS |
204 | } |
205 | ||
206 | IV | |
14d89041 | 207 | PerlIOScalar_flush(pTHX_ PerlIO * f) |
f6c77cf1 | 208 | { |
c33e8be1 | 209 | PERL_UNUSED_ARG(f); |
14d89041 | 210 | return 0; |
f6c77cf1 NIS |
211 | } |
212 | ||
213 | STDCHAR * | |
14d89041 | 214 | PerlIOScalar_get_base(pTHX_ PerlIO * f) |
f6c77cf1 | 215 | { |
14d89041 NIS |
216 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); |
217 | if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { | |
ffe0bb5a | 218 | SvGETMAGIC(s->var); |
14d89041 NIS |
219 | return (STDCHAR *) SvPV_nolen(s->var); |
220 | } | |
9849c14c | 221 | return (STDCHAR *) NULL; |
f6c77cf1 NIS |
222 | } |
223 | ||
224 | STDCHAR * | |
14d89041 | 225 | PerlIOScalar_get_ptr(pTHX_ PerlIO * f) |
f6c77cf1 | 226 | { |
14d89041 NIS |
227 | if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { |
228 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); | |
229 | return PerlIOScalar_get_base(aTHX_ f) + s->posn; | |
230 | } | |
9849c14c | 231 | return (STDCHAR *) NULL; |
f6c77cf1 NIS |
232 | } |
233 | ||
234 | SSize_t | |
14d89041 | 235 | PerlIOScalar_get_cnt(pTHX_ PerlIO * f) |
f6c77cf1 | 236 | { |
14d89041 NIS |
237 | if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { |
238 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); | |
71edc894 | 239 | STRLEN len; |
ffe0bb5a | 240 | SvGETMAGIC(s->var); |
71edc894 FC |
241 | if (isGV_with_GP(s->var)) |
242 | (void)SvPV(s->var,len); | |
243 | else len = SvCUR(s->var); | |
244 | if (len > (STRLEN) s->posn) | |
245 | return len - (STRLEN)s->posn; | |
14d89041 NIS |
246 | else |
247 | return 0; | |
248 | } | |
75effbe0 | 249 | return 0; |
f6c77cf1 NIS |
250 | } |
251 | ||
252 | Size_t | |
14d89041 | 253 | PerlIOScalar_bufsiz(pTHX_ PerlIO * f) |
f6c77cf1 | 254 | { |
14d89041 NIS |
255 | if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { |
256 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); | |
ffe0bb5a | 257 | SvGETMAGIC(s->var); |
14d89041 NIS |
258 | return SvCUR(s->var); |
259 | } | |
260 | return 0; | |
f6c77cf1 NIS |
261 | } |
262 | ||
263 | void | |
14d89041 | 264 | PerlIOScalar_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt) |
f6c77cf1 | 265 | { |
14d89041 | 266 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); |
71edc894 | 267 | STRLEN len; |
c33e8be1 | 268 | PERL_UNUSED_ARG(ptr); |
ffe0bb5a | 269 | SvGETMAGIC(s->var); |
71edc894 FC |
270 | if (isGV_with_GP(s->var)) (void)SvPV(s->var,len); |
271 | else len = SvCUR(s->var); | |
272 | s->posn = len - cnt; | |
f6c77cf1 NIS |
273 | } |
274 | ||
275 | PerlIO * | |
14d89041 NIS |
276 | PerlIOScalar_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, IV n, |
277 | const char *mode, int fd, int imode, int perm, | |
278 | PerlIO * f, int narg, SV ** args) | |
f6c77cf1 | 279 | { |
14d89041 | 280 | SV *arg = (narg > 0) ? *args : PerlIOArg; |
c33e8be1 Z |
281 | PERL_UNUSED_ARG(fd); |
282 | PERL_UNUSED_ARG(imode); | |
283 | PERL_UNUSED_ARG(perm); | |
14d89041 NIS |
284 | if (SvROK(arg) || SvPOK(arg)) { |
285 | if (!f) { | |
286 | f = PerlIO_allocate(aTHX); | |
287 | } | |
e3feee4e | 288 | if ( (f = PerlIO_push(aTHX_ f, self, mode, arg)) ) { |
14d89041 NIS |
289 | PerlIOBase(f)->flags |= PERLIO_F_OPEN; |
290 | } | |
291 | return f; | |
292 | } | |
293 | return NULL; | |
f6c77cf1 NIS |
294 | } |
295 | ||
ecdeb87c | 296 | SV * |
14d89041 | 297 | PerlIOScalar_arg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags) |
ecdeb87c | 298 | { |
14d89041 NIS |
299 | PerlIOScalar *s = PerlIOSelf(f, PerlIOScalar); |
300 | SV *var = s->var; | |
301 | if (flags & PERLIO_DUP_CLONE) | |
302 | var = PerlIO_sv_dup(aTHX_ var, param); | |
303 | else if (flags & PERLIO_DUP_FD) { | |
304 | /* Equivalent (guesses NI-S) of dup() is to create a new scalar */ | |
305 | var = newSVsv(var); | |
306 | } | |
307 | else { | |
308 | var = SvREFCNT_inc(var); | |
309 | } | |
310 | return newRV_noinc(var); | |
ecdeb87c NIS |
311 | } |
312 | ||
8cf8f3d1 | 313 | PerlIO * |
14d89041 NIS |
314 | PerlIOScalar_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param, |
315 | int flags) | |
8cf8f3d1 | 316 | { |
14d89041 NIS |
317 | if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) { |
318 | PerlIOScalar *fs = PerlIOSelf(f, PerlIOScalar); | |
319 | PerlIOScalar *os = PerlIOSelf(o, PerlIOScalar); | |
320 | /* var has been set by implicit push */ | |
321 | fs->posn = os->posn; | |
322 | } | |
323 | return f; | |
8cf8f3d1 | 324 | } |
f6c77cf1 | 325 | |
27da23d5 | 326 | PERLIO_FUNCS_DECL(PerlIO_scalar) = { |
14d89041 NIS |
327 | sizeof(PerlIO_funcs), |
328 | "scalar", | |
329 | sizeof(PerlIOScalar), | |
330 | PERLIO_K_BUFFERED | PERLIO_K_RAW, | |
331 | PerlIOScalar_pushed, | |
332 | PerlIOScalar_popped, | |
333 | PerlIOScalar_open, | |
334 | PerlIOBase_binmode, | |
335 | PerlIOScalar_arg, | |
336 | PerlIOScalar_fileno, | |
337 | PerlIOScalar_dup, | |
ffe0bb5a | 338 | PerlIOScalar_read, |
3ff3a8b6 | 339 | NULL, /* unread */ |
14d89041 NIS |
340 | PerlIOScalar_write, |
341 | PerlIOScalar_seek, | |
342 | PerlIOScalar_tell, | |
343 | PerlIOScalar_close, | |
344 | PerlIOScalar_flush, | |
345 | PerlIOScalar_fill, | |
346 | PerlIOBase_eof, | |
347 | PerlIOBase_error, | |
348 | PerlIOBase_clearerr, | |
349 | PerlIOBase_setlinebuf, | |
350 | PerlIOScalar_get_base, | |
351 | PerlIOScalar_bufsiz, | |
352 | PerlIOScalar_get_ptr, | |
353 | PerlIOScalar_get_cnt, | |
354 | PerlIOScalar_set_ptrcnt, | |
f6c77cf1 NIS |
355 | }; |
356 | ||
357 | ||
358 | #endif /* Layers available */ | |
359 | ||
e934609f | 360 | MODULE = PerlIO::scalar PACKAGE = PerlIO::scalar |
f6c77cf1 | 361 | |
acf4de66 A |
362 | PROTOTYPES: ENABLE |
363 | ||
f6c77cf1 NIS |
364 | BOOT: |
365 | { | |
366 | #ifdef PERLIO_LAYERS | |
27da23d5 | 367 | PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_scalar)); |
f6c77cf1 NIS |
368 | #endif |
369 | } | |
370 |