line |
stmt |
bran |
cond |
sub |
time |
code |
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
|
|
|
|
|
|
HV * stash; |
13
|
|
|
|
|
|
SV * obj; |
14
|
|
|
|
|
|
SV * var; |
15
|
|
|
|
|
|
SSize_t cnt; |
16
|
|
|
|
|
|
IO * io; |
17
|
|
|
|
|
|
SV * fh; |
18
|
|
|
|
|
|
CV *PUSHED; |
19
|
|
|
|
|
|
CV *POPPED; |
20
|
|
|
|
|
|
CV *OPEN; |
21
|
|
|
|
|
|
CV *FDOPEN; |
22
|
|
|
|
|
|
CV *SYSOPEN; |
23
|
|
|
|
|
|
CV *GETARG; |
24
|
|
|
|
|
|
CV *FILENO; |
25
|
|
|
|
|
|
CV *READ; |
26
|
|
|
|
|
|
CV *WRITE; |
27
|
|
|
|
|
|
CV *FILL; |
28
|
|
|
|
|
|
CV *CLOSE; |
29
|
|
|
|
|
|
CV *SEEK; |
30
|
|
|
|
|
|
CV *TELL; |
31
|
|
|
|
|
|
CV *UNREAD; |
32
|
|
|
|
|
|
CV *FLUSH; |
33
|
|
|
|
|
|
CV *SETLINEBUF; |
34
|
|
|
|
|
|
CV *CLEARERR; |
35
|
|
|
|
|
|
CV *mERROR; |
36
|
|
|
|
|
|
CV *mEOF; |
37
|
|
|
|
|
|
CV *BINMODE; |
38
|
|
|
|
|
|
CV *UTF8; |
39
|
|
|
|
|
|
} PerlIOVia; |
40
|
|
|
|
|
|
|
41
|
|
|
|
|
|
#define MYMethod(x) #x,&s->x |
42
|
|
|
|
|
|
|
43
|
|
|
|
|
|
CV * |
44
|
106
|
|
|
|
|
PerlIOVia_fetchmethod(pTHX_ PerlIOVia * s, const char *method, CV ** save) |
45
|
|
|
|
|
|
{ |
46
|
106
|
|
|
|
|
GV *gv = gv_fetchmeth(s->stash, method, strlen(method), 0); |
47
|
|
|
|
|
|
#if 0 |
48
|
|
|
|
|
|
Perl_warn(aTHX_ "Lookup %s::%s => %p", HvNAME_get(s->stash), method, gv); |
49
|
|
|
|
|
|
#endif |
50
|
106
|
|
|
|
|
if (gv) { |
51
|
28
|
|
|
|
|
return *save = GvCV(gv); |
52
|
|
|
|
|
|
} |
53
|
|
|
|
|
|
else { |
54
|
78
|
|
|
|
|
return *save = (CV *) - 1; |
55
|
|
|
|
|
|
} |
56
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
58
|
|
|
|
|
|
/* |
59
|
|
|
|
|
|
* Try and call method, possibly via cached lookup. |
60
|
|
|
|
|
|
* If method does not exist return Nullsv (caller may fallback to another approach |
61
|
|
|
|
|
|
* If method does exist call it with flags passing variable number of args |
62
|
|
|
|
|
|
* Last arg is a "filehandle" to layer below (if present) |
63
|
|
|
|
|
|
* Returns scalar returned by method (if any) otherwise sv_undef |
64
|
|
|
|
|
|
*/ |
65
|
|
|
|
|
|
|
66
|
|
|
|
|
|
SV * |
67
|
114
|
|
|
|
|
PerlIOVia_method(pTHX_ PerlIO * f, const char *method, CV ** save, int flags, |
68
|
|
|
|
|
|
...) |
69
|
|
|
|
|
|
{ |
70
|
114
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
71
|
|
|
|
|
|
CV *cv = |
72
|
114
|
|
|
|
|
(*save) ? *save : PerlIOVia_fetchmethod(aTHX_ s, method, save); |
73
|
|
|
|
|
|
SV *result = Nullsv; |
74
|
|
|
|
|
|
va_list ap; |
75
|
114
|
|
|
|
|
va_start(ap, flags); |
76
|
114
|
|
|
|
|
if (cv != (CV *) - 1) { |
77
|
|
|
|
|
|
IV count; |
78
|
30
|
|
|
|
|
dSP; |
79
|
|
|
|
|
|
SV *arg; |
80
|
30
|
|
|
|
|
PUSHSTACKi(PERLSI_MAGIC); |
81
|
30
|
|
|
|
|
ENTER; |
82
|
30
|
|
|
|
|
SPAGAIN; |
83
|
30
|
|
|
|
|
PUSHMARK(sp); |
84
|
30
|
|
|
|
|
XPUSHs(s->obj); |
85
|
78
|
|
|
|
|
while ((arg = va_arg(ap, SV *))) { |
86
|
18
|
|
|
|
|
XPUSHs(arg); |
87
|
|
|
|
|
|
} |
88
|
30
|
|
|
|
|
if (*PerlIONext(f)) { |
89
|
16
|
|
|
|
|
if (!s->fh) { |
90
|
8
|
|
|
|
|
GV *gv = newGVgen(HvNAME_get(s->stash)); |
91
|
8
|
|
|
|
|
GvIOp(gv) = newIO(); |
92
|
8
|
|
|
|
|
s->fh = newRV((SV *) gv); |
93
|
8
|
|
|
|
|
s->io = GvIOp(gv); |
94
|
8
|
|
|
|
|
if (gv) { |
95
|
|
|
|
|
|
/* shamelessly stolen from IO::File's new_tmpfile() */ |
96
|
8
|
|
|
|
|
(void) hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD); |
97
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
} |
99
|
16
|
|
|
|
|
IoIFP(s->io) = PerlIONext(f); |
100
|
16
|
|
|
|
|
IoOFP(s->io) = PerlIONext(f); |
101
|
16
|
|
|
|
|
XPUSHs(s->fh); |
102
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
else { |
104
|
14
|
|
|
|
|
PerlIO_debug("No next\n"); |
105
|
|
|
|
|
|
/* FIXME: How should this work for OPEN etc? */ |
106
|
|
|
|
|
|
} |
107
|
30
|
|
|
|
|
PUTBACK; |
108
|
30
|
|
|
|
|
count = call_sv((SV *) cv, flags); |
109
|
30
|
|
|
|
|
if (count) { |
110
|
30
|
|
|
|
|
SPAGAIN; |
111
|
30
|
|
|
|
|
result = POPs; |
112
|
30
|
|
|
|
|
PUTBACK; |
113
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
else { |
115
|
|
|
|
|
|
result = &PL_sv_undef; |
116
|
|
|
|
|
|
} |
117
|
30
|
|
|
|
|
LEAVE; |
118
|
30
|
|
|
|
|
POPSTACK; |
119
|
|
|
|
|
|
} |
120
|
114
|
|
|
|
|
va_end(ap); |
121
|
114
|
|
|
|
|
return result; |
122
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
124
|
|
|
|
|
|
IV |
125
|
20
|
|
|
|
|
PerlIOVia_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, |
126
|
|
|
|
|
|
PerlIO_funcs * tab) |
127
|
|
|
|
|
|
{ |
128
|
20
|
|
|
|
|
IV code = PerlIOBase_pushed(aTHX_ f, mode, Nullsv, tab); |
129
|
20
|
|
|
|
|
if (code == 0) { |
130
|
20
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
131
|
20
|
|
|
|
|
if (!arg) { |
132
|
0
|
|
|
|
|
if (ckWARN(WARN_LAYER)) |
133
|
0
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_LAYER), |
134
|
|
|
|
|
|
"No package specified"); |
135
|
0
|
|
|
|
|
errno = EINVAL; |
136
|
|
|
|
|
|
code = -1; |
137
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
else { |
139
|
20
|
|
|
|
|
STRLEN pkglen = 0; |
140
|
20
|
|
|
|
|
const char *pkg = SvPV(arg, pkglen); |
141
|
20
|
|
|
|
|
s->obj = |
142
|
20
|
|
|
|
|
newSVpvn(Perl_form(aTHX_ "PerlIO::via::%s", pkg), |
143
|
|
|
|
|
|
pkglen + 13); |
144
|
20
|
|
|
|
|
s->stash = gv_stashpvn(SvPVX_const(s->obj), pkglen + 13, 0); |
145
|
20
|
|
|
|
|
if (!s->stash) { |
146
|
16
|
|
|
|
|
SvREFCNT_dec(s->obj); |
147
|
16
|
|
|
|
|
s->obj = SvREFCNT_inc(arg); |
148
|
16
|
|
|
|
|
s->stash = gv_stashpvn(pkg, pkglen, 0); |
149
|
|
|
|
|
|
} |
150
|
20
|
|
|
|
|
if (s->stash) { |
151
|
|
|
|
|
|
char lmode[8]; |
152
|
|
|
|
|
|
SV *modesv; |
153
|
|
|
|
|
|
SV *result; |
154
|
16
|
|
|
|
|
if (!mode) { |
155
|
|
|
|
|
|
/* binmode() passes NULL - so find out what mode is */ |
156
|
0
|
|
|
|
|
mode = PerlIO_modestr(f,lmode); |
157
|
|
|
|
|
|
} |
158
|
16
|
|
|
|
|
modesv = newSVpvn_flags(mode, strlen(mode), SVs_TEMP); |
159
|
16
|
|
|
|
|
result = PerlIOVia_method(aTHX_ f, MYMethod(PUSHED), G_SCALAR, |
160
|
|
|
|
|
|
modesv, Nullsv); |
161
|
16
|
|
|
|
|
if (result) { |
162
|
14
|
|
|
|
|
if (sv_isobject(result)) { |
163
|
10
|
|
|
|
|
SvREFCNT_dec(s->obj); |
164
|
10
|
|
|
|
|
s->obj = SvREFCNT_inc(result); |
165
|
|
|
|
|
|
} |
166
|
4
|
|
|
|
|
else if (SvIV(result) != 0) |
167
|
4
|
|
|
|
|
return SvIV(result); |
168
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
else { |
170
|
|
|
|
|
|
goto push_failed; |
171
|
|
|
|
|
|
} |
172
|
10
|
|
|
|
|
modesv = (*PerlIONext(f) && (PerlIOBase(PerlIONext(f))->flags & PERLIO_F_UTF8)) |
173
|
10
|
|
|
|
|
? &PL_sv_yes : &PL_sv_no; |
174
|
10
|
|
|
|
|
result = PerlIOVia_method(aTHX_ f, MYMethod(UTF8), G_SCALAR, modesv, Nullsv); |
175
|
10
|
|
|
|
|
if (result && SvTRUE(result)) { |
176
|
0
|
|
|
|
|
PerlIOBase(f)->flags |= PERLIO_F_UTF8; |
177
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
else { |
179
|
10
|
|
|
|
|
PerlIOBase(f)->flags &= ~PERLIO_F_UTF8; |
180
|
|
|
|
|
|
} |
181
|
10
|
|
|
|
|
if (PerlIOVia_fetchmethod(aTHX_ s, MYMethod(FILL)) == |
182
|
|
|
|
|
|
(CV *) - 1) |
183
|
0
|
|
|
|
|
PerlIOBase(f)->flags &= ~PERLIO_F_FASTGETS; |
184
|
|
|
|
|
|
else |
185
|
10
|
|
|
|
|
PerlIOBase(f)->flags |= PERLIO_F_FASTGETS; |
186
|
|
|
|
|
|
} |
187
|
|
|
|
|
|
else { |
188
|
4
|
|
|
|
|
if (ckWARN(WARN_LAYER)) |
189
|
2
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_LAYER), |
190
|
|
|
|
|
|
"Cannot find package '%.*s'", (int) pkglen, |
191
|
|
|
|
|
|
pkg); |
192
|
|
|
|
|
|
push_failed: |
193
|
|
|
|
|
|
#ifdef ENOSYS |
194
|
6
|
|
|
|
|
errno = ENOSYS; |
195
|
|
|
|
|
|
#else |
196
|
|
|
|
|
|
#ifdef ENOENT |
197
|
|
|
|
|
|
errno = ENOENT; |
198
|
|
|
|
|
|
#endif |
199
|
|
|
|
|
|
#endif |
200
|
|
|
|
|
|
code = -1; |
201
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
} |
204
|
16
|
|
|
|
|
return code; |
205
|
|
|
|
|
|
} |
206
|
|
|
|
|
|
|
207
|
|
|
|
|
|
PerlIO * |
208
|
20
|
|
|
|
|
PerlIOVia_open(pTHX_ PerlIO_funcs * self, PerlIO_list_t * layers, |
209
|
|
|
|
|
|
IV n, const char *mode, int fd, int imode, int perm, |
210
|
|
|
|
|
|
PerlIO * f, int narg, SV ** args) |
211
|
|
|
|
|
|
{ |
212
|
20
|
|
|
|
|
if (!f) { |
213
|
20
|
|
|
|
|
f = PerlIO_push(aTHX_ PerlIO_allocate(aTHX), self, mode, |
214
|
|
|
|
|
|
PerlIOArg); |
215
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
else { |
217
|
|
|
|
|
|
/* Reopen */ |
218
|
0
|
|
|
|
|
if (!PerlIO_push(aTHX_ f, self, mode, PerlIOArg)) |
219
|
|
|
|
|
|
return NULL; |
220
|
|
|
|
|
|
} |
221
|
20
|
|
|
|
|
if (f) { |
222
|
10
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
223
|
|
|
|
|
|
SV *result = Nullsv; |
224
|
10
|
|
|
|
|
if (fd >= 0) { |
225
|
0
|
|
|
|
|
SV *fdsv = sv_2mortal(newSViv(fd)); |
226
|
0
|
|
|
|
|
result = |
227
|
0
|
|
|
|
|
PerlIOVia_method(aTHX_ f, MYMethod(FDOPEN), G_SCALAR, fdsv, |
228
|
|
|
|
|
|
Nullsv); |
229
|
|
|
|
|
|
} |
230
|
10
|
|
|
|
|
else if (narg > 0) { |
231
|
10
|
|
|
|
|
if (*mode == '#') { |
232
|
0
|
|
|
|
|
SV *imodesv = sv_2mortal(newSViv(imode)); |
233
|
0
|
|
|
|
|
SV *permsv = sv_2mortal(newSViv(perm)); |
234
|
0
|
|
|
|
|
result = |
235
|
0
|
|
|
|
|
PerlIOVia_method(aTHX_ f, MYMethod(SYSOPEN), G_SCALAR, |
236
|
|
|
|
|
|
*args, imodesv, permsv, Nullsv); |
237
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
else { |
239
|
10
|
|
|
|
|
result = |
240
|
10
|
|
|
|
|
PerlIOVia_method(aTHX_ f, MYMethod(OPEN), G_SCALAR, |
241
|
|
|
|
|
|
*args, Nullsv); |
242
|
|
|
|
|
|
} |
243
|
|
|
|
|
|
} |
244
|
10
|
|
|
|
|
if (result) { |
245
|
0
|
|
|
|
|
if (sv_isobject(result)) |
246
|
0
|
|
|
|
|
s->obj = SvREFCNT_inc(result); |
247
|
0
|
|
|
|
|
else if (!SvTRUE(result)) { |
248
|
|
|
|
|
|
return NULL; |
249
|
|
|
|
|
|
} |
250
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
else { |
252
|
|
|
|
|
|
/* Required open method not present */ |
253
|
|
|
|
|
|
PerlIO_funcs *tab = NULL; |
254
|
10
|
|
|
|
|
IV m = n - 1; |
255
|
20
|
|
|
|
|
while (m >= 0) { |
256
|
10
|
|
|
|
|
PerlIO_funcs *t = |
257
|
|
|
|
|
|
PerlIO_layer_fetch(aTHX_ layers, m, NULL); |
258
|
10
|
|
|
|
|
if (t && t->Open) { |
259
|
|
|
|
|
|
tab = t; |
260
|
|
|
|
|
|
break; |
261
|
|
|
|
|
|
} |
262
|
0
|
|
|
|
|
m--; |
263
|
|
|
|
|
|
} |
264
|
10
|
|
|
|
|
if (tab) { |
265
|
20
|
|
|
|
|
if ((*tab->Open) (aTHX_ tab, layers, m, mode, fd, imode, |
266
|
10
|
|
|
|
|
perm, PerlIONext(f), narg, args)) { |
267
|
16
|
|
|
|
|
PerlIO_debug("Opened with %s => %p->%p\n", tab->name, |
268
|
16
|
|
|
|
|
PerlIONext(f), *PerlIONext(f)); |
269
|
8
|
|
|
|
|
if (m + 1 < n) { |
270
|
|
|
|
|
|
/* |
271
|
|
|
|
|
|
* More layers above the one that we used to open - |
272
|
|
|
|
|
|
* apply them now |
273
|
|
|
|
|
|
*/ |
274
|
0
|
|
|
|
|
if (PerlIO_apply_layera |
275
|
0
|
|
|
|
|
(aTHX_ PerlIONext(f), mode, layers, m + 1, |
276
|
|
|
|
|
|
n) != 0) { |
277
|
|
|
|
|
|
/* If pushing layers fails close the file */ |
278
|
0
|
|
|
|
|
PerlIO_close(f); |
279
|
|
|
|
|
|
f = NULL; |
280
|
|
|
|
|
|
} |
281
|
|
|
|
|
|
} |
282
|
|
|
|
|
|
/* FIXME - Call an OPENED method here ? */ |
283
|
8
|
|
|
|
|
return f; |
284
|
|
|
|
|
|
} |
285
|
|
|
|
|
|
else { |
286
|
4
|
|
|
|
|
PerlIO_debug("Open fail %s => %p->%p\n", tab->name, |
287
|
4
|
|
|
|
|
PerlIONext(f), *PerlIONext(f)); |
288
|
|
|
|
|
|
/* Sub-layer open failed */ |
289
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
} |
291
|
|
|
|
|
|
else { |
292
|
0
|
|
|
|
|
PerlIO_debug("Nothing to open with"); |
293
|
|
|
|
|
|
/* Nothing to do the open */ |
294
|
|
|
|
|
|
} |
295
|
2
|
|
|
|
|
PerlIO_pop(aTHX_ f); |
296
|
2
|
|
|
|
|
return NULL; |
297
|
|
|
|
|
|
} |
298
|
|
|
|
|
|
} |
299
|
10
|
|
|
|
|
return f; |
300
|
|
|
|
|
|
} |
301
|
|
|
|
|
|
|
302
|
|
|
|
|
|
IV |
303
|
20
|
|
|
|
|
PerlIOVia_popped(pTHX_ PerlIO * f) |
304
|
|
|
|
|
|
{ |
305
|
20
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
306
|
20
|
|
|
|
|
PerlIOVia_method(aTHX_ f, MYMethod(POPPED), G_VOID, Nullsv); |
307
|
20
|
|
|
|
|
if (s->var) { |
308
|
0
|
|
|
|
|
SvREFCNT_dec(s->var); |
309
|
0
|
|
|
|
|
s->var = Nullsv; |
310
|
|
|
|
|
|
} |
311
|
|
|
|
|
|
|
312
|
20
|
|
|
|
|
if (s->io) { |
313
|
8
|
|
|
|
|
IoIFP(s->io) = NULL; |
314
|
8
|
|
|
|
|
IoOFP(s->io) = NULL; |
315
|
|
|
|
|
|
} |
316
|
20
|
|
|
|
|
if (s->fh) { |
317
|
8
|
|
|
|
|
SvREFCNT_dec(s->fh); |
318
|
8
|
|
|
|
|
s->fh = Nullsv; |
319
|
8
|
|
|
|
|
s->io = NULL; |
320
|
|
|
|
|
|
} |
321
|
20
|
|
|
|
|
if (s->obj) { |
322
|
20
|
|
|
|
|
SvREFCNT_dec(s->obj); |
323
|
20
|
|
|
|
|
s->obj = Nullsv; |
324
|
|
|
|
|
|
} |
325
|
20
|
|
|
|
|
return 0; |
326
|
|
|
|
|
|
} |
327
|
|
|
|
|
|
|
328
|
|
|
|
|
|
IV |
329
|
8
|
|
|
|
|
PerlIOVia_close(pTHX_ PerlIO * f) |
330
|
|
|
|
|
|
{ |
331
|
8
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
332
|
8
|
|
|
|
|
IV code = PerlIOBase_close(aTHX_ f); |
333
|
8
|
|
|
|
|
SV *result = |
334
|
8
|
|
|
|
|
PerlIOVia_method(aTHX_ f, MYMethod(CLOSE), G_SCALAR, Nullsv); |
335
|
8
|
|
|
|
|
if (result && SvIV(result) != 0) |
336
|
0
|
|
|
|
|
code = SvIV(result); |
337
|
8
|
|
|
|
|
PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); |
338
|
8
|
|
|
|
|
return code; |
339
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
341
|
|
|
|
|
|
IV |
342
|
10
|
|
|
|
|
PerlIOVia_fileno(pTHX_ PerlIO * f) |
343
|
|
|
|
|
|
{ |
344
|
10
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
345
|
10
|
|
|
|
|
SV *result = |
346
|
10
|
|
|
|
|
PerlIOVia_method(aTHX_ f, MYMethod(FILENO), G_SCALAR, Nullsv); |
347
|
10
|
|
|
|
|
return (result) ? SvIV(result) : PerlIO_fileno(PerlIONext(f)); |
348
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
350
|
|
|
|
|
|
IV |
351
|
0
|
|
|
|
|
PerlIOVia_binmode(pTHX_ PerlIO * f) |
352
|
|
|
|
|
|
{ |
353
|
0
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
354
|
0
|
|
|
|
|
SV *result = |
355
|
0
|
|
|
|
|
PerlIOVia_method(aTHX_ f, MYMethod(BINMODE), G_SCALAR, Nullsv); |
356
|
0
|
|
|
|
|
if (!result || !SvOK(result)) { |
357
|
0
|
|
|
|
|
PerlIO_pop(aTHX_ f); |
358
|
0
|
|
|
|
|
return 0; |
359
|
|
|
|
|
|
} |
360
|
0
|
|
|
|
|
return SvIV(result); |
361
|
|
|
|
|
|
} |
362
|
|
|
|
|
|
|
363
|
|
|
|
|
|
IV |
364
|
0
|
|
|
|
|
PerlIOVia_seek(pTHX_ PerlIO * f, Off_t offset, int whence) |
365
|
|
|
|
|
|
{ |
366
|
0
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
367
|
0
|
|
|
|
|
SV *offsv = sv_2mortal(sizeof(Off_t) > sizeof(IV) |
368
|
|
|
|
|
|
? newSVnv((NV)offset) : newSViv((IV)offset)); |
369
|
0
|
|
|
|
|
SV *whsv = sv_2mortal(newSViv(whence)); |
370
|
0
|
|
|
|
|
SV *result = |
371
|
0
|
|
|
|
|
PerlIOVia_method(aTHX_ f, MYMethod(SEEK), G_SCALAR, offsv, whsv, |
372
|
|
|
|
|
|
Nullsv); |
373
|
|
|
|
|
|
#if Off_t_size == 8 && defined(CONDOP_SIZE) && CONDOP_SIZE < Off_t_size |
374
|
|
|
|
|
|
if (result) |
375
|
|
|
|
|
|
return (Off_t) SvIV(result); |
376
|
|
|
|
|
|
else |
377
|
|
|
|
|
|
return (Off_t) -1; |
378
|
|
|
|
|
|
#else |
379
|
0
|
|
|
|
|
return (result) ? SvIV(result) : -1; |
380
|
|
|
|
|
|
#endif |
381
|
|
|
|
|
|
} |
382
|
|
|
|
|
|
|
383
|
|
|
|
|
|
Off_t |
384
|
2
|
|
|
|
|
PerlIOVia_tell(pTHX_ PerlIO * f) |
385
|
|
|
|
|
|
{ |
386
|
2
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
387
|
2
|
|
|
|
|
SV *result = |
388
|
2
|
|
|
|
|
PerlIOVia_method(aTHX_ f, MYMethod(TELL), G_SCALAR, Nullsv); |
389
|
2
|
|
|
|
|
return (result) |
390
|
0
|
|
|
|
|
? (SvNOK(result) ? (Off_t)SvNV(result) : (Off_t)SvIV(result)) |
391
|
2
|
|
|
|
|
: (Off_t) - 1; |
392
|
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
394
|
|
|
|
|
|
SSize_t |
395
|
0
|
|
|
|
|
PerlIOVia_unread(pTHX_ PerlIO * f, const void *vbuf, Size_t count) |
396
|
|
|
|
|
|
{ |
397
|
0
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
398
|
0
|
|
|
|
|
SV *buf = newSVpvn_flags((char *) vbuf, count, SVs_TEMP); |
399
|
0
|
|
|
|
|
SV *result = |
400
|
0
|
|
|
|
|
PerlIOVia_method(aTHX_ f, MYMethod(UNREAD), G_SCALAR, buf, Nullsv); |
401
|
0
|
|
|
|
|
if (result) |
402
|
0
|
|
|
|
|
return (SSize_t) SvIV(result); |
403
|
|
|
|
|
|
else { |
404
|
0
|
|
|
|
|
return PerlIOBase_unread(aTHX_ f, vbuf, count); |
405
|
|
|
|
|
|
} |
406
|
|
|
|
|
|
} |
407
|
|
|
|
|
|
|
408
|
|
|
|
|
|
SSize_t |
409
|
12
|
|
|
|
|
PerlIOVia_read(pTHX_ PerlIO * f, void *vbuf, Size_t count) |
410
|
|
|
|
|
|
{ |
411
|
|
|
|
|
|
SSize_t rd = 0; |
412
|
12
|
|
|
|
|
if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { |
413
|
12
|
|
|
|
|
if (PerlIOBase(f)->flags & PERLIO_F_FASTGETS) { |
414
|
12
|
|
|
|
|
rd = PerlIOBase_read(aTHX_ f, vbuf, count); |
415
|
|
|
|
|
|
} |
416
|
|
|
|
|
|
else { |
417
|
0
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
418
|
0
|
|
|
|
|
SV *buf = sv_2mortal(newSV(count)); |
419
|
0
|
|
|
|
|
SV *n = sv_2mortal(newSViv(count)); |
420
|
0
|
|
|
|
|
SV *result = |
421
|
0
|
|
|
|
|
PerlIOVia_method(aTHX_ f, MYMethod(READ), G_SCALAR, buf, n, |
422
|
|
|
|
|
|
Nullsv); |
423
|
0
|
|
|
|
|
if (result) { |
424
|
0
|
|
|
|
|
rd = (SSize_t) SvIV(result); |
425
|
0
|
|
|
|
|
Move(SvPVX(buf), vbuf, rd, char); |
426
|
0
|
|
|
|
|
return rd; |
427
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
} |
430
|
12
|
|
|
|
|
return rd; |
431
|
|
|
|
|
|
} |
432
|
|
|
|
|
|
|
433
|
|
|
|
|
|
SSize_t |
434
|
4
|
|
|
|
|
PerlIOVia_write(pTHX_ PerlIO * f, const void *vbuf, Size_t count) |
435
|
|
|
|
|
|
{ |
436
|
4
|
|
|
|
|
if (PerlIOBase(f)->flags & PERLIO_F_CANWRITE) { |
437
|
4
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
438
|
4
|
|
|
|
|
SV *buf = newSVpvn((char *) vbuf, count); |
439
|
4
|
|
|
|
|
SV *result = |
440
|
4
|
|
|
|
|
PerlIOVia_method(aTHX_ f, MYMethod(WRITE), G_SCALAR, buf, |
441
|
|
|
|
|
|
Nullsv); |
442
|
4
|
|
|
|
|
SvREFCNT_dec(buf); |
443
|
4
|
|
|
|
|
if (result) |
444
|
4
|
|
|
|
|
return (SSize_t) SvIV(result); |
445
|
|
|
|
|
|
return -1; |
446
|
|
|
|
|
|
} |
447
|
|
|
|
|
|
return 0; |
448
|
|
|
|
|
|
} |
449
|
|
|
|
|
|
|
450
|
|
|
|
|
|
IV |
451
|
12
|
|
|
|
|
PerlIOVia_fill(pTHX_ PerlIO * f) |
452
|
|
|
|
|
|
{ |
453
|
12
|
|
|
|
|
if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { |
454
|
12
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
455
|
12
|
|
|
|
|
SV *result = |
456
|
12
|
|
|
|
|
PerlIOVia_method(aTHX_ f, MYMethod(FILL), G_SCALAR, Nullsv); |
457
|
12
|
|
|
|
|
if (s->var) { |
458
|
8
|
|
|
|
|
SvREFCNT_dec(s->var); |
459
|
8
|
|
|
|
|
s->var = Nullsv; |
460
|
|
|
|
|
|
} |
461
|
12
|
|
|
|
|
if (result && SvOK(result)) { |
462
|
8
|
|
|
|
|
STRLEN len = 0; |
463
|
8
|
|
|
|
|
const char *p = SvPV(result, len); |
464
|
8
|
|
|
|
|
s->var = newSVpvn(p, len); |
465
|
8
|
|
|
|
|
s->cnt = SvCUR(s->var); |
466
|
8
|
|
|
|
|
return 0; |
467
|
|
|
|
|
|
} |
468
|
|
|
|
|
|
else |
469
|
4
|
|
|
|
|
PerlIOBase(f)->flags |= PERLIO_F_EOF; |
470
|
|
|
|
|
|
} |
471
|
|
|
|
|
|
return -1; |
472
|
|
|
|
|
|
} |
473
|
|
|
|
|
|
|
474
|
|
|
|
|
|
IV |
475
|
8
|
|
|
|
|
PerlIOVia_flush(pTHX_ PerlIO * f) |
476
|
|
|
|
|
|
{ |
477
|
8
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
478
|
8
|
|
|
|
|
SV *result = |
479
|
8
|
|
|
|
|
PerlIOVia_method(aTHX_ f, MYMethod(FLUSH), G_SCALAR, Nullsv); |
480
|
8
|
|
|
|
|
if (s->var && s->cnt > 0) { |
481
|
0
|
|
|
|
|
SvREFCNT_dec(s->var); |
482
|
0
|
|
|
|
|
s->var = Nullsv; |
483
|
|
|
|
|
|
} |
484
|
8
|
|
|
|
|
return (result) ? SvIV(result) : 0; |
485
|
|
|
|
|
|
} |
486
|
|
|
|
|
|
|
487
|
|
|
|
|
|
STDCHAR * |
488
|
0
|
|
|
|
|
PerlIOVia_get_base(pTHX_ PerlIO * f) |
489
|
|
|
|
|
|
{ |
490
|
0
|
|
|
|
|
if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { |
491
|
0
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
492
|
0
|
|
|
|
|
if (s->var) { |
493
|
0
|
|
|
|
|
return (STDCHAR *) SvPVX(s->var); |
494
|
|
|
|
|
|
} |
495
|
|
|
|
|
|
} |
496
|
|
|
|
|
|
return (STDCHAR *) NULL; |
497
|
|
|
|
|
|
} |
498
|
|
|
|
|
|
|
499
|
|
|
|
|
|
STDCHAR * |
500
|
28
|
|
|
|
|
PerlIOVia_get_ptr(pTHX_ PerlIO * f) |
501
|
|
|
|
|
|
{ |
502
|
28
|
|
|
|
|
if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { |
503
|
28
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
504
|
28
|
|
|
|
|
if (s->var) { |
505
|
20
|
|
|
|
|
STDCHAR *p = (STDCHAR *) (SvEND(s->var) - s->cnt); |
506
|
20
|
|
|
|
|
return p; |
507
|
|
|
|
|
|
} |
508
|
|
|
|
|
|
} |
509
|
|
|
|
|
|
return (STDCHAR *) NULL; |
510
|
|
|
|
|
|
} |
511
|
|
|
|
|
|
|
512
|
|
|
|
|
|
SSize_t |
513
|
40
|
|
|
|
|
PerlIOVia_get_cnt(pTHX_ PerlIO * f) |
514
|
|
|
|
|
|
{ |
515
|
40
|
|
|
|
|
if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { |
516
|
40
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
517
|
40
|
|
|
|
|
if (s->var) { |
518
|
28
|
|
|
|
|
return s->cnt; |
519
|
|
|
|
|
|
} |
520
|
|
|
|
|
|
} |
521
|
|
|
|
|
|
return 0; |
522
|
|
|
|
|
|
} |
523
|
|
|
|
|
|
|
524
|
|
|
|
|
|
Size_t |
525
|
0
|
|
|
|
|
PerlIOVia_bufsiz(pTHX_ PerlIO * f) |
526
|
|
|
|
|
|
{ |
527
|
0
|
|
|
|
|
if (PerlIOBase(f)->flags & PERLIO_F_CANREAD) { |
528
|
0
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
529
|
0
|
|
|
|
|
if (s->var) |
530
|
0
|
|
|
|
|
return SvCUR(s->var); |
531
|
|
|
|
|
|
} |
532
|
|
|
|
|
|
return 0; |
533
|
|
|
|
|
|
} |
534
|
|
|
|
|
|
|
535
|
|
|
|
|
|
void |
536
|
28
|
|
|
|
|
PerlIOVia_set_ptrcnt(pTHX_ PerlIO * f, STDCHAR * ptr, SSize_t cnt) |
537
|
|
|
|
|
|
{ |
538
|
28
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
539
|
|
|
|
|
|
PERL_UNUSED_ARG(ptr); |
540
|
28
|
|
|
|
|
s->cnt = cnt; |
541
|
28
|
|
|
|
|
} |
542
|
|
|
|
|
|
|
543
|
|
|
|
|
|
void |
544
|
0
|
|
|
|
|
PerlIOVia_setlinebuf(pTHX_ PerlIO * f) |
545
|
|
|
|
|
|
{ |
546
|
0
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
547
|
0
|
|
|
|
|
PerlIOVia_method(aTHX_ f, MYMethod(SETLINEBUF), G_VOID, Nullsv); |
548
|
0
|
|
|
|
|
PerlIOBase_setlinebuf(aTHX_ f); |
549
|
0
|
|
|
|
|
} |
550
|
|
|
|
|
|
|
551
|
|
|
|
|
|
void |
552
|
2
|
|
|
|
|
PerlIOVia_clearerr(pTHX_ PerlIO * f) |
553
|
|
|
|
|
|
{ |
554
|
2
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
555
|
2
|
|
|
|
|
PerlIOVia_method(aTHX_ f, MYMethod(CLEARERR), G_VOID, Nullsv); |
556
|
2
|
|
|
|
|
PerlIOBase_clearerr(aTHX_ f); |
557
|
2
|
|
|
|
|
} |
558
|
|
|
|
|
|
|
559
|
|
|
|
|
|
IV |
560
|
12
|
|
|
|
|
PerlIOVia_error(pTHX_ PerlIO * f) |
561
|
|
|
|
|
|
{ |
562
|
12
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
563
|
12
|
|
|
|
|
SV *result = |
564
|
12
|
|
|
|
|
PerlIOVia_method(aTHX_ f, "ERROR", &s->mERROR, G_SCALAR, Nullsv); |
565
|
12
|
|
|
|
|
return (result) ? SvIV(result) : PerlIOBase_error(aTHX_ f); |
566
|
|
|
|
|
|
} |
567
|
|
|
|
|
|
|
568
|
|
|
|
|
|
IV |
569
|
0
|
|
|
|
|
PerlIOVia_eof(pTHX_ PerlIO * f) |
570
|
|
|
|
|
|
{ |
571
|
0
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
572
|
0
|
|
|
|
|
SV *result = |
573
|
0
|
|
|
|
|
PerlIOVia_method(aTHX_ f, "EOF", &s->mEOF, G_SCALAR, Nullsv); |
574
|
0
|
|
|
|
|
return (result) ? SvIV(result) : PerlIOBase_eof(aTHX_ f); |
575
|
|
|
|
|
|
} |
576
|
|
|
|
|
|
|
577
|
|
|
|
|
|
SV * |
578
|
0
|
|
|
|
|
PerlIOVia_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags) |
579
|
|
|
|
|
|
{ |
580
|
0
|
|
|
|
|
PerlIOVia *s = PerlIOSelf(f, PerlIOVia); |
581
|
|
|
|
|
|
PERL_UNUSED_ARG(param); |
582
|
|
|
|
|
|
PERL_UNUSED_ARG(flags); |
583
|
0
|
|
|
|
|
return PerlIOVia_method(aTHX_ f, MYMethod(GETARG), G_SCALAR, Nullsv); |
584
|
|
|
|
|
|
} |
585
|
|
|
|
|
|
|
586
|
|
|
|
|
|
PerlIO * |
587
|
0
|
|
|
|
|
PerlIOVia_dup(pTHX_ PerlIO * f, PerlIO * o, CLONE_PARAMS * param, |
588
|
|
|
|
|
|
int flags) |
589
|
|
|
|
|
|
{ |
590
|
0
|
|
|
|
|
if ((f = PerlIOBase_dup(aTHX_ f, o, param, flags))) { |
591
|
|
|
|
|
|
/* Most of the fields will lazily set themselves up as needed |
592
|
|
|
|
|
|
stash and obj have been set up by the implied push |
593
|
|
|
|
|
|
*/ |
594
|
|
|
|
|
|
} |
595
|
0
|
|
|
|
|
return f; |
596
|
|
|
|
|
|
} |
597
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
600
|
|
|
|
|
|
PERLIO_FUNCS_DECL(PerlIO_object) = { |
601
|
|
|
|
|
|
sizeof(PerlIO_funcs), |
602
|
|
|
|
|
|
"via", |
603
|
|
|
|
|
|
sizeof(PerlIOVia), |
604
|
|
|
|
|
|
PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT, |
605
|
|
|
|
|
|
PerlIOVia_pushed, |
606
|
|
|
|
|
|
PerlIOVia_popped, |
607
|
|
|
|
|
|
PerlIOVia_open, /* NULL, */ |
608
|
|
|
|
|
|
PerlIOVia_binmode, /* NULL, */ |
609
|
|
|
|
|
|
PerlIOVia_getarg, |
610
|
|
|
|
|
|
PerlIOVia_fileno, |
611
|
|
|
|
|
|
PerlIOVia_dup, |
612
|
|
|
|
|
|
PerlIOVia_read, |
613
|
|
|
|
|
|
PerlIOVia_unread, |
614
|
|
|
|
|
|
PerlIOVia_write, |
615
|
|
|
|
|
|
PerlIOVia_seek, |
616
|
|
|
|
|
|
PerlIOVia_tell, |
617
|
|
|
|
|
|
PerlIOVia_close, |
618
|
|
|
|
|
|
PerlIOVia_flush, |
619
|
|
|
|
|
|
PerlIOVia_fill, |
620
|
|
|
|
|
|
PerlIOVia_eof, |
621
|
|
|
|
|
|
PerlIOVia_error, |
622
|
|
|
|
|
|
PerlIOVia_clearerr, |
623
|
|
|
|
|
|
PerlIOVia_setlinebuf, |
624
|
|
|
|
|
|
PerlIOVia_get_base, |
625
|
|
|
|
|
|
PerlIOVia_bufsiz, |
626
|
|
|
|
|
|
PerlIOVia_get_ptr, |
627
|
|
|
|
|
|
PerlIOVia_get_cnt, |
628
|
|
|
|
|
|
PerlIOVia_set_ptrcnt, |
629
|
|
|
|
|
|
}; |
630
|
|
|
|
|
|
|
631
|
|
|
|
|
|
|
632
|
|
|
|
|
|
#endif /* Layers available */ |
633
|
|
|
|
|
|
|
634
|
|
|
|
|
|
MODULE = PerlIO::via PACKAGE = PerlIO::via |
635
|
|
|
|
|
|
PROTOTYPES: ENABLE; |
636
|
|
|
|
|
|
|
637
|
|
|
|
|
|
BOOT: |
638
|
|
|
|
|
|
{ |
639
|
|
|
|
|
|
#ifdef PERLIO_LAYERS |
640
|
4
|
|
|
|
|
PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_object)); |
641
|
|
|
|
|
|
#endif |
642
|
|
|
|
|
|
} |
643
|
|
|
|
|
|
|
644
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
647
|
|
|
|
|
|
|