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
|
|
|
|
|
|
#define U8 U8 |
6
|
|
|
|
|
|
|
7
|
|
|
|
|
|
#define OUR_DEFAULT_FB "Encode::PERLQQ" |
8
|
|
|
|
|
|
|
9
|
|
|
|
|
|
#if defined(USE_PERLIO) && !defined(USE_SFIO) |
10
|
|
|
|
|
|
|
11
|
|
|
|
|
|
/* Define an encoding "layer" in the perliol.h sense. |
12
|
|
|
|
|
|
|
13
|
|
|
|
|
|
The layer defined here "inherits" in an object-oriented sense from |
14
|
|
|
|
|
|
the "perlio" layer with its PerlIOBuf_* "methods". The |
15
|
|
|
|
|
|
implementation is particularly efficient as until Encode settles |
16
|
|
|
|
|
|
down there is no point in tryint to tune it. |
17
|
|
|
|
|
|
|
18
|
|
|
|
|
|
The layer works by overloading the "fill" and "flush" methods. |
19
|
|
|
|
|
|
|
20
|
|
|
|
|
|
"fill" calls "SUPER::fill" in perl terms, then calls the encode OO |
21
|
|
|
|
|
|
perl API to convert the encoded data to UTF-8 form, then copies it |
22
|
|
|
|
|
|
back to the buffer. The "base class's" read methods then see the |
23
|
|
|
|
|
|
UTF-8 data. |
24
|
|
|
|
|
|
|
25
|
|
|
|
|
|
"flush" transforms the UTF-8 data deposited by the "base class's |
26
|
|
|
|
|
|
write method in the buffer back into the encoded form using the |
27
|
|
|
|
|
|
encode OO perl API, then copies data back into the buffer and calls |
28
|
|
|
|
|
|
"SUPER::flush. |
29
|
|
|
|
|
|
|
30
|
|
|
|
|
|
Note that "flush" is _also_ called for read mode - we still do the |
31
|
|
|
|
|
|
(back)-translate so that the base class's "flush" sees the |
32
|
|
|
|
|
|
correct number of encoded chars for positioning the seek |
33
|
|
|
|
|
|
pointer. (This double translation is the worst performance issue - |
34
|
|
|
|
|
|
particularly with all-perl encode engine.) |
35
|
|
|
|
|
|
|
36
|
|
|
|
|
|
*/ |
37
|
|
|
|
|
|
|
38
|
|
|
|
|
|
#include "perliol.h" |
39
|
|
|
|
|
|
|
40
|
|
|
|
|
|
typedef struct { |
41
|
|
|
|
|
|
PerlIOBuf base; /* PerlIOBuf stuff */ |
42
|
|
|
|
|
|
SV *bufsv; /* buffer seen by layers above */ |
43
|
|
|
|
|
|
SV *dataSV; /* data we have read from layer below */ |
44
|
|
|
|
|
|
SV *enc; /* the encoding object */ |
45
|
|
|
|
|
|
SV *chk; /* CHECK in Encode methods */ |
46
|
|
|
|
|
|
int flags; /* Flags currently just needs lines */ |
47
|
|
|
|
|
|
int inEncodeCall; /* trap recursive encode calls */ |
48
|
|
|
|
|
|
} PerlIOEncode; |
49
|
|
|
|
|
|
|
50
|
|
|
|
|
|
#define NEEDS_LINES 1 |
51
|
|
|
|
|
|
|
52
|
|
|
|
|
|
SV * |
53
|
50
|
|
|
|
|
PerlIOEncode_getarg(pTHX_ PerlIO * f, CLONE_PARAMS * param, int flags) |
54
|
|
|
|
|
|
{ |
55
|
50
|
|
|
|
|
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); |
56
|
|
|
|
|
|
SV *sv = &PL_sv_undef; |
57
|
|
|
|
|
|
PERL_UNUSED_ARG(param); |
58
|
|
|
|
|
|
PERL_UNUSED_ARG(flags); |
59
|
50
|
|
|
|
|
if (e->enc) { |
60
|
50
|
|
|
|
|
dSP; |
61
|
|
|
|
|
|
/* Not 100% sure stack swap is right thing to do during dup ... */ |
62
|
50
|
|
|
|
|
PUSHSTACKi(PERLSI_MAGIC); |
63
|
50
|
|
|
|
|
SPAGAIN; |
64
|
50
|
|
|
|
|
ENTER; |
65
|
50
|
|
|
|
|
SAVETMPS; |
66
|
50
|
|
|
|
|
PUSHMARK(sp); |
67
|
50
|
|
|
|
|
XPUSHs(e->enc); |
68
|
50
|
|
|
|
|
PUTBACK; |
69
|
50
|
|
|
|
|
if (call_method("name", G_SCALAR) == 1) { |
70
|
50
|
|
|
|
|
SPAGAIN; |
71
|
50
|
|
|
|
|
sv = newSVsv(POPs); |
72
|
50
|
|
|
|
|
PUTBACK; |
73
|
|
|
|
|
|
} |
74
|
50
|
|
|
|
|
FREETMPS; |
75
|
50
|
|
|
|
|
LEAVE; |
76
|
50
|
|
|
|
|
POPSTACK; |
77
|
|
|
|
|
|
} |
78
|
50
|
|
|
|
|
return sv; |
79
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
81
|
|
|
|
|
|
IV |
82
|
418
|
|
|
|
|
PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs *tab) |
83
|
|
|
|
|
|
{ |
84
|
418
|
|
|
|
|
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); |
85
|
418
|
|
|
|
|
dSP; |
86
|
418
|
|
|
|
|
IV code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv,tab); |
87
|
|
|
|
|
|
SV *result = Nullsv; |
88
|
|
|
|
|
|
|
89
|
418
|
|
|
|
|
PUSHSTACKi(PERLSI_MAGIC); |
90
|
418
|
|
|
|
|
SPAGAIN; |
91
|
|
|
|
|
|
|
92
|
418
|
|
|
|
|
ENTER; |
93
|
418
|
|
|
|
|
SAVETMPS; |
94
|
|
|
|
|
|
|
95
|
418
|
|
|
|
|
PUSHMARK(sp); |
96
|
418
|
|
|
|
|
XPUSHs(arg); |
97
|
418
|
|
|
|
|
PUTBACK; |
98
|
418
|
|
|
|
|
if (call_pv("Encode::find_encoding", G_SCALAR) != 1) { |
99
|
|
|
|
|
|
/* should never happen */ |
100
|
0
|
|
|
|
|
Perl_die(aTHX_ "Encode::find_encoding did not return a value"); |
101
|
0
|
|
|
|
|
return -1; |
102
|
|
|
|
|
|
} |
103
|
418
|
|
|
|
|
SPAGAIN; |
104
|
418
|
|
|
|
|
result = POPs; |
105
|
418
|
|
|
|
|
PUTBACK; |
106
|
|
|
|
|
|
|
107
|
418
|
|
|
|
|
if (!SvROK(result) || !SvOBJECT(SvRV(result))) { |
108
|
4
|
|
|
|
|
e->enc = Nullsv; |
109
|
4
|
|
|
|
|
if (ckWARN_d(WARN_IO)) |
110
|
4
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"", |
111
|
|
|
|
|
|
arg); |
112
|
4
|
|
|
|
|
errno = EINVAL; |
113
|
4
|
|
|
|
|
code = -1; |
114
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
else { |
116
|
|
|
|
|
|
|
117
|
|
|
|
|
|
/* $enc->renew */ |
118
|
414
|
|
|
|
|
PUSHMARK(sp); |
119
|
414
|
|
|
|
|
XPUSHs(result); |
120
|
414
|
|
|
|
|
PUTBACK; |
121
|
414
|
|
|
|
|
if (call_method("renew",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) { |
122
|
0
|
|
|
|
|
if (ckWARN_d(WARN_IO)) |
123
|
0
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support renew method", |
124
|
|
|
|
|
|
arg); |
125
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
else { |
127
|
414
|
|
|
|
|
SPAGAIN; |
128
|
414
|
|
|
|
|
result = POPs; |
129
|
414
|
|
|
|
|
PUTBACK; |
130
|
|
|
|
|
|
} |
131
|
414
|
|
|
|
|
e->enc = newSVsv(result); |
132
|
414
|
|
|
|
|
PUSHMARK(sp); |
133
|
414
|
|
|
|
|
XPUSHs(e->enc); |
134
|
414
|
|
|
|
|
PUTBACK; |
135
|
414
|
|
|
|
|
if (call_method("needs_lines",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) { |
136
|
0
|
|
|
|
|
if (ckWARN_d(WARN_IO)) |
137
|
0
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support needs_lines", |
138
|
|
|
|
|
|
arg); |
139
|
|
|
|
|
|
} |
140
|
|
|
|
|
|
else { |
141
|
414
|
|
|
|
|
SPAGAIN; |
142
|
414
|
|
|
|
|
result = POPs; |
143
|
414
|
|
|
|
|
PUTBACK; |
144
|
414
|
|
|
|
|
if (SvTRUE(result)) { |
145
|
38
|
|
|
|
|
e->flags |= NEEDS_LINES; |
146
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
} |
148
|
414
|
|
|
|
|
PerlIOBase(f)->flags |= PERLIO_F_UTF8; |
149
|
|
|
|
|
|
} |
150
|
|
|
|
|
|
|
151
|
418
|
|
|
|
|
e->chk = newSVsv(get_sv("PerlIO::encoding::fallback", 0)); |
152
|
418
|
|
|
|
|
e->inEncodeCall = 0; |
153
|
|
|
|
|
|
|
154
|
418
|
|
|
|
|
FREETMPS; |
155
|
418
|
|
|
|
|
LEAVE; |
156
|
418
|
|
|
|
|
POPSTACK; |
157
|
418
|
|
|
|
|
return code; |
158
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
160
|
|
|
|
|
|
IV |
161
|
418
|
|
|
|
|
PerlIOEncode_popped(pTHX_ PerlIO * f) |
162
|
|
|
|
|
|
{ |
163
|
418
|
|
|
|
|
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); |
164
|
418
|
|
|
|
|
if (e->enc) { |
165
|
414
|
|
|
|
|
SvREFCNT_dec(e->enc); |
166
|
414
|
|
|
|
|
e->enc = Nullsv; |
167
|
|
|
|
|
|
} |
168
|
418
|
|
|
|
|
if (e->bufsv) { |
169
|
62
|
|
|
|
|
SvREFCNT_dec(e->bufsv); |
170
|
62
|
|
|
|
|
e->bufsv = Nullsv; |
171
|
|
|
|
|
|
} |
172
|
418
|
|
|
|
|
if (e->dataSV) { |
173
|
106
|
|
|
|
|
SvREFCNT_dec(e->dataSV); |
174
|
106
|
|
|
|
|
e->dataSV = Nullsv; |
175
|
|
|
|
|
|
} |
176
|
418
|
|
|
|
|
if (e->chk) { |
177
|
418
|
|
|
|
|
SvREFCNT_dec(e->chk); |
178
|
418
|
|
|
|
|
e->chk = Nullsv; |
179
|
|
|
|
|
|
} |
180
|
418
|
|
|
|
|
return 0; |
181
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
183
|
|
|
|
|
|
STDCHAR * |
184
|
7522
|
|
|
|
|
PerlIOEncode_get_base(pTHX_ PerlIO * f) |
185
|
|
|
|
|
|
{ |
186
|
7522
|
|
|
|
|
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); |
187
|
7522
|
|
|
|
|
if (!e->base.bufsiz) |
188
|
296
|
|
|
|
|
e->base.bufsiz = 1024; |
189
|
7522
|
|
|
|
|
if (!e->bufsv) { |
190
|
296
|
|
|
|
|
e->bufsv = newSV(e->base.bufsiz); |
191
|
296
|
|
|
|
|
sv_setpvn(e->bufsv, "", 0); |
192
|
|
|
|
|
|
} |
193
|
7522
|
|
|
|
|
e->base.buf = (STDCHAR *) SvPVX(e->bufsv); |
194
|
7522
|
|
|
|
|
if (!e->base.ptr) |
195
|
1024
|
|
|
|
|
e->base.ptr = e->base.buf; |
196
|
7522
|
|
|
|
|
if (!e->base.end) |
197
|
1024
|
|
|
|
|
e->base.end = e->base.buf; |
198
|
7522
|
|
|
|
|
if (e->base.ptr < e->base.buf |
199
|
7522
|
|
|
|
|
|| e->base.ptr > e->base.buf + SvLEN(e->bufsv)) { |
200
|
0
|
|
|
|
|
Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr, |
201
|
0
|
|
|
|
|
e->base.buf + SvLEN(e->bufsv)); |
202
|
0
|
|
|
|
|
abort(); |
203
|
|
|
|
|
|
} |
204
|
7522
|
|
|
|
|
if (SvLEN(e->bufsv) < e->base.bufsiz) { |
205
|
52
|
|
|
|
|
SSize_t poff = e->base.ptr - e->base.buf; |
206
|
52
|
|
|
|
|
SSize_t eoff = e->base.end - e->base.buf; |
207
|
52
|
|
|
|
|
e->base.buf = (STDCHAR *) SvGROW(e->bufsv, e->base.bufsiz); |
208
|
52
|
|
|
|
|
e->base.ptr = e->base.buf + poff; |
209
|
52
|
|
|
|
|
e->base.end = e->base.buf + eoff; |
210
|
|
|
|
|
|
} |
211
|
7522
|
|
|
|
|
if (e->base.ptr < e->base.buf |
212
|
7522
|
|
|
|
|
|| e->base.ptr > e->base.buf + SvLEN(e->bufsv)) { |
213
|
0
|
|
|
|
|
Perl_warn(aTHX_ " ptr %p(%p)%p", e->base.buf, e->base.ptr, |
214
|
0
|
|
|
|
|
e->base.buf + SvLEN(e->bufsv)); |
215
|
0
|
|
|
|
|
abort(); |
216
|
|
|
|
|
|
} |
217
|
7522
|
|
|
|
|
return e->base.buf; |
218
|
|
|
|
|
|
} |
219
|
|
|
|
|
|
|
220
|
|
|
|
|
|
IV |
221
|
780
|
|
|
|
|
PerlIOEncode_fill(pTHX_ PerlIO * f) |
222
|
|
|
|
|
|
{ |
223
|
780
|
|
|
|
|
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); |
224
|
780
|
|
|
|
|
dSP; |
225
|
|
|
|
|
|
IV code = 0; |
226
|
|
|
|
|
|
PerlIO *n; |
227
|
|
|
|
|
|
SSize_t avail; |
228
|
|
|
|
|
|
|
229
|
780
|
|
|
|
|
if (PerlIO_flush(f) != 0) |
230
|
|
|
|
|
|
return -1; |
231
|
780
|
|
|
|
|
n = PerlIONext(f); |
232
|
780
|
|
|
|
|
if (!PerlIO_fast_gets(n)) { |
233
|
|
|
|
|
|
/* Things get too messy if we don't have a buffer layer |
234
|
|
|
|
|
|
push a :perlio to do the job */ |
235
|
|
|
|
|
|
char mode[8]; |
236
|
0
|
|
|
|
|
n = PerlIO_push(aTHX_ n, &PerlIO_perlio, PerlIO_modestr(f,mode), Nullsv); |
237
|
0
|
|
|
|
|
if (!n) { |
238
|
0
|
|
|
|
|
Perl_die(aTHX_ "panic: cannot push :perlio for %p",f); |
239
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
} |
241
|
780
|
|
|
|
|
PUSHSTACKi(PERLSI_MAGIC); |
242
|
780
|
|
|
|
|
SPAGAIN; |
243
|
780
|
|
|
|
|
ENTER; |
244
|
780
|
|
|
|
|
SAVETMPS; |
245
|
|
|
|
|
|
retry: |
246
|
816
|
|
|
|
|
avail = PerlIO_get_cnt(n); |
247
|
816
|
|
|
|
|
if (avail <= 0) { |
248
|
266
|
|
|
|
|
avail = PerlIO_fill(n); |
249
|
266
|
|
|
|
|
if (avail == 0) { |
250
|
162
|
|
|
|
|
avail = PerlIO_get_cnt(n); |
251
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
else { |
253
|
104
|
|
|
|
|
if (!PerlIO_error(n) && PerlIO_eof(n)) |
254
|
|
|
|
|
|
avail = 0; |
255
|
|
|
|
|
|
} |
256
|
|
|
|
|
|
} |
257
|
1492
|
|
|
|
|
if (avail > 0 || (e->flags & NEEDS_LINES)) { |
258
|
728
|
|
|
|
|
STDCHAR *ptr = PerlIO_get_ptr(n); |
259
|
728
|
|
|
|
|
SSize_t use = (avail >= 0) ? avail : 0; |
260
|
|
|
|
|
|
SV *uni; |
261
|
|
|
|
|
|
char *s = NULL; |
262
|
728
|
|
|
|
|
STRLEN len = 0; |
263
|
728
|
|
|
|
|
e->base.ptr = e->base.end = (STDCHAR *) NULL; |
264
|
728
|
|
|
|
|
(void) PerlIOEncode_get_base(aTHX_ f); |
265
|
728
|
|
|
|
|
if (!e->dataSV) |
266
|
106
|
|
|
|
|
e->dataSV = newSV(0); |
267
|
728
|
|
|
|
|
if (SvTYPE(e->dataSV) < SVt_PV) { |
268
|
106
|
|
|
|
|
sv_upgrade(e->dataSV,SVt_PV); |
269
|
|
|
|
|
|
} |
270
|
728
|
|
|
|
|
if (e->flags & NEEDS_LINES) { |
271
|
|
|
|
|
|
/* Encoding needs whole lines (e.g. iso-2022-*) |
272
|
|
|
|
|
|
search back from end of available data for |
273
|
|
|
|
|
|
and line marker |
274
|
|
|
|
|
|
*/ |
275
|
96
|
|
|
|
|
STDCHAR *nl = ptr+use-1; |
276
|
3152
|
|
|
|
|
while (nl >= ptr) { |
277
|
3008
|
|
|
|
|
if (*nl == '\n') { |
278
|
|
|
|
|
|
break; |
279
|
|
|
|
|
|
} |
280
|
2960
|
|
|
|
|
nl--; |
281
|
|
|
|
|
|
} |
282
|
96
|
|
|
|
|
if (nl >= ptr && *nl == '\n') { |
283
|
|
|
|
|
|
/* found a line - take up to and including that */ |
284
|
48
|
|
|
|
|
use = (nl+1)-ptr; |
285
|
|
|
|
|
|
} |
286
|
48
|
|
|
|
|
else if (avail > 0) { |
287
|
|
|
|
|
|
/* No line, but not EOF - append avail to the pending data */ |
288
|
32
|
|
|
|
|
sv_catpvn(e->dataSV, (char*)ptr, use); |
289
|
32
|
|
|
|
|
PerlIO_set_ptrcnt(n, ptr+use, 0); |
290
|
32
|
|
|
|
|
goto retry; |
291
|
|
|
|
|
|
} |
292
|
16
|
|
|
|
|
else if (!SvCUR(e->dataSV)) { |
293
|
|
|
|
|
|
goto end_of_file; |
294
|
|
|
|
|
|
} |
295
|
|
|
|
|
|
} |
296
|
680
|
|
|
|
|
if (SvCUR(e->dataSV)) { |
297
|
|
|
|
|
|
/* something left over from last time - create a normal |
298
|
|
|
|
|
|
SV with new data appended |
299
|
|
|
|
|
|
*/ |
300
|
36
|
|
|
|
|
if (use + SvCUR(e->dataSV) > e->base.bufsiz) { |
301
|
8
|
|
|
|
|
if (e->flags & NEEDS_LINES) { |
302
|
|
|
|
|
|
/* Have to grow buffer */ |
303
|
4
|
|
|
|
|
e->base.bufsiz = use + SvCUR(e->dataSV); |
304
|
4
|
|
|
|
|
PerlIOEncode_get_base(aTHX_ f); |
305
|
|
|
|
|
|
} |
306
|
|
|
|
|
|
else { |
307
|
4
|
|
|
|
|
use = e->base.bufsiz - SvCUR(e->dataSV); |
308
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
} |
310
|
36
|
|
|
|
|
sv_catpvn(e->dataSV,(char*)ptr,use); |
311
|
|
|
|
|
|
} |
312
|
|
|
|
|
|
else { |
313
|
|
|
|
|
|
/* Create a "dummy" SV to represent the available data from layer below */ |
314
|
644
|
|
|
|
|
if (SvLEN(e->dataSV) && SvPVX_const(e->dataSV)) { |
315
|
78
|
|
|
|
|
Safefree(SvPVX_mutable(e->dataSV)); |
316
|
|
|
|
|
|
} |
317
|
644
|
|
|
|
|
if (use > (SSize_t)e->base.bufsiz) { |
318
|
492
|
|
|
|
|
if (e->flags & NEEDS_LINES) { |
319
|
|
|
|
|
|
/* Have to grow buffer */ |
320
|
16
|
|
|
|
|
e->base.bufsiz = use; |
321
|
16
|
|
|
|
|
PerlIOEncode_get_base(aTHX_ f); |
322
|
|
|
|
|
|
} |
323
|
|
|
|
|
|
else { |
324
|
476
|
|
|
|
|
use = e->base.bufsiz; |
325
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
} |
327
|
644
|
|
|
|
|
SvPV_set(e->dataSV, (char *) ptr); |
328
|
644
|
|
|
|
|
SvLEN_set(e->dataSV, 0); /* Hands off sv.c - it isn't yours */ |
329
|
644
|
|
|
|
|
SvCUR_set(e->dataSV,use); |
330
|
644
|
|
|
|
|
SvPOK_only(e->dataSV); |
331
|
|
|
|
|
|
} |
332
|
680
|
|
|
|
|
SvUTF8_off(e->dataSV); |
333
|
680
|
|
|
|
|
PUSHMARK(sp); |
334
|
680
|
|
|
|
|
XPUSHs(e->enc); |
335
|
680
|
|
|
|
|
XPUSHs(e->dataSV); |
336
|
680
|
|
|
|
|
XPUSHs(e->chk); |
337
|
680
|
|
|
|
|
PUTBACK; |
338
|
680
|
|
|
|
|
if (call_method("decode", G_SCALAR) != 1) { |
339
|
0
|
|
|
|
|
Perl_die(aTHX_ "panic: decode did not return a value"); |
340
|
|
|
|
|
|
} |
341
|
680
|
|
|
|
|
SPAGAIN; |
342
|
680
|
|
|
|
|
uni = POPs; |
343
|
680
|
|
|
|
|
PUTBACK; |
344
|
|
|
|
|
|
/* No cows allowed. */ |
345
|
680
|
|
|
|
|
if (SvTHINKFIRST(e->dataSV)) SvPV_force_nolen(e->dataSV); |
346
|
|
|
|
|
|
/* Now get translated string (forced to UTF-8) and use as buffer */ |
347
|
680
|
|
|
|
|
if (SvPOK(uni)) { |
348
|
680
|
|
|
|
|
s = SvPVutf8(uni, len); |
349
|
|
|
|
|
|
#ifdef PARANOID_ENCODE_CHECKS |
350
|
|
|
|
|
|
if (len && !is_utf8_string((U8*)s,len)) { |
351
|
|
|
|
|
|
Perl_warn(aTHX_ "panic: decode did not return UTF-8 '%.*s'",(int) len,s); |
352
|
|
|
|
|
|
} |
353
|
|
|
|
|
|
#endif |
354
|
|
|
|
|
|
} |
355
|
680
|
|
|
|
|
if (len > 0) { |
356
|
|
|
|
|
|
/* Got _something */ |
357
|
|
|
|
|
|
/* if decode gave us back dataSV then data may vanish when |
358
|
|
|
|
|
|
we do ptrcnt adjust - so take our copy now. |
359
|
|
|
|
|
|
(The copy is a pain - need a put-it-here option for decode.) |
360
|
|
|
|
|
|
*/ |
361
|
676
|
|
|
|
|
sv_setpvn(e->bufsv,s,len); |
362
|
676
|
|
|
|
|
e->base.ptr = e->base.buf = (STDCHAR*)SvPVX(e->bufsv); |
363
|
676
|
|
|
|
|
e->base.end = e->base.ptr + SvCUR(e->bufsv); |
364
|
676
|
|
|
|
|
PerlIOBase(f)->flags |= PERLIO_F_RDBUF; |
365
|
676
|
|
|
|
|
SvUTF8_on(e->bufsv); |
366
|
|
|
|
|
|
|
367
|
|
|
|
|
|
/* Adjust ptr/cnt not taking anything which |
368
|
|
|
|
|
|
did not translate - not clear this is a win */ |
369
|
|
|
|
|
|
/* compute amount we took */ |
370
|
676
|
|
|
|
|
if (!SvPOKp(e->dataSV)) (void)SvPV_force_nolen(e->dataSV); |
371
|
676
|
|
|
|
|
use -= SvCUR(e->dataSV); |
372
|
676
|
|
|
|
|
PerlIO_set_ptrcnt(n, ptr+use, (avail-use)); |
373
|
|
|
|
|
|
/* and as we did not take it it isn't pending */ |
374
|
676
|
|
|
|
|
SvCUR_set(e->dataSV,0); |
375
|
|
|
|
|
|
} else { |
376
|
|
|
|
|
|
/* Got nothing - assume partial character so we need some more */ |
377
|
|
|
|
|
|
/* Make sure e->dataSV is a normal SV before re-filling as |
378
|
|
|
|
|
|
buffer alias will change under us |
379
|
|
|
|
|
|
*/ |
380
|
4
|
|
|
|
|
s = SvPV(e->dataSV,len); |
381
|
4
|
|
|
|
|
sv_setpvn(e->dataSV,s,len); |
382
|
4
|
|
|
|
|
PerlIO_set_ptrcnt(n, ptr+use, (avail-use)); |
383
|
4
|
|
|
|
|
goto retry; |
384
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
} |
386
|
|
|
|
|
|
else { |
387
|
|
|
|
|
|
end_of_file: |
388
|
|
|
|
|
|
code = -1; |
389
|
104
|
|
|
|
|
if (avail == 0) |
390
|
100
|
|
|
|
|
PerlIOBase(f)->flags |= PERLIO_F_EOF; |
391
|
|
|
|
|
|
else |
392
|
4
|
|
|
|
|
PerlIOBase(f)->flags |= PERLIO_F_ERROR; |
393
|
|
|
|
|
|
} |
394
|
780
|
|
|
|
|
FREETMPS; |
395
|
780
|
|
|
|
|
LEAVE; |
396
|
780
|
|
|
|
|
POPSTACK; |
397
|
780
|
|
|
|
|
return code; |
398
|
|
|
|
|
|
} |
399
|
|
|
|
|
|
|
400
|
|
|
|
|
|
IV |
401
|
9626
|
|
|
|
|
PerlIOEncode_flush(pTHX_ PerlIO * f) |
402
|
|
|
|
|
|
{ |
403
|
9626
|
|
|
|
|
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); |
404
|
|
|
|
|
|
IV code = 0; |
405
|
|
|
|
|
|
|
406
|
9626
|
|
|
|
|
if (e->bufsv) { |
407
|
9356
|
|
|
|
|
dSP; |
408
|
|
|
|
|
|
SV *str; |
409
|
|
|
|
|
|
char *s; |
410
|
|
|
|
|
|
STRLEN len; |
411
|
|
|
|
|
|
SSize_t count = 0; |
412
|
9356
|
|
|
|
|
if ((PerlIOBase(f)->flags & PERLIO_F_WRBUF) && (e->base.ptr > e->base.buf)) { |
413
|
6478
|
|
|
|
|
if (e->inEncodeCall) return 0; |
414
|
|
|
|
|
|
/* Write case - encode the buffer and write() to layer below */ |
415
|
6478
|
|
|
|
|
PUSHSTACKi(PERLSI_MAGIC); |
416
|
6478
|
|
|
|
|
SPAGAIN; |
417
|
6478
|
|
|
|
|
ENTER; |
418
|
6478
|
|
|
|
|
SAVETMPS; |
419
|
6478
|
|
|
|
|
PUSHMARK(sp); |
420
|
6478
|
|
|
|
|
XPUSHs(e->enc); |
421
|
6478
|
|
|
|
|
SvCUR_set(e->bufsv, e->base.ptr - e->base.buf); |
422
|
6478
|
|
|
|
|
SvUTF8_on(e->bufsv); |
423
|
6478
|
|
|
|
|
XPUSHs(e->bufsv); |
424
|
6478
|
|
|
|
|
XPUSHs(e->chk); |
425
|
6478
|
|
|
|
|
PUTBACK; |
426
|
6478
|
|
|
|
|
e->inEncodeCall = 1; |
427
|
6478
|
|
|
|
|
if (call_method("encode", G_SCALAR) != 1) { |
428
|
0
|
|
|
|
|
e->inEncodeCall = 0; |
429
|
0
|
|
|
|
|
Perl_die(aTHX_ "panic: encode did not return a value"); |
430
|
|
|
|
|
|
} |
431
|
6478
|
|
|
|
|
e->inEncodeCall = 0; |
432
|
6478
|
|
|
|
|
SPAGAIN; |
433
|
6478
|
|
|
|
|
str = POPs; |
434
|
6478
|
|
|
|
|
PUTBACK; |
435
|
6478
|
|
|
|
|
s = SvPV(str, len); |
436
|
6478
|
|
|
|
|
count = PerlIO_write(PerlIONext(f),s,len); |
437
|
6478
|
|
|
|
|
if ((STRLEN)count != len) { |
438
|
|
|
|
|
|
code = -1; |
439
|
|
|
|
|
|
} |
440
|
6478
|
|
|
|
|
FREETMPS; |
441
|
6478
|
|
|
|
|
LEAVE; |
442
|
6478
|
|
|
|
|
POPSTACK; |
443
|
6478
|
|
|
|
|
if (PerlIO_flush(PerlIONext(f)) != 0) { |
444
|
|
|
|
|
|
code = -1; |
445
|
|
|
|
|
|
} |
446
|
6478
|
|
|
|
|
if (!SvPOKp(e->bufsv) || SvTHINKFIRST(e->bufsv)) |
447
|
28
|
|
|
|
|
(void)SvPV_force_nolen(e->bufsv); |
448
|
6478
|
|
|
|
|
if ((STDCHAR *)SvPVX(e->bufsv) != e->base.buf) { |
449
|
36
|
|
|
|
|
e->base.ptr = SvEND(e->bufsv); |
450
|
36
|
|
|
|
|
e->base.end = SvPVX(e->bufsv) + (e->base.end-e->base.buf); |
451
|
36
|
|
|
|
|
e->base.buf = (STDCHAR *)SvPVX(e->bufsv); |
452
|
|
|
|
|
|
} |
453
|
6478
|
|
|
|
|
(void)PerlIOEncode_get_base(aTHX_ f); |
454
|
6478
|
|
|
|
|
if (SvCUR(e->bufsv)) { |
455
|
|
|
|
|
|
/* Did not all translate */ |
456
|
218
|
|
|
|
|
e->base.ptr = e->base.buf+SvCUR(e->bufsv); |
457
|
218
|
|
|
|
|
return code; |
458
|
|
|
|
|
|
} |
459
|
|
|
|
|
|
} |
460
|
2878
|
|
|
|
|
else if ((PerlIOBase(f)->flags & PERLIO_F_RDBUF)) { |
461
|
|
|
|
|
|
/* read case */ |
462
|
|
|
|
|
|
/* if we have any untranslated stuff then unread that first */ |
463
|
|
|
|
|
|
/* FIXME - unread is fragile is there a better way ? */ |
464
|
892
|
|
|
|
|
if (e->dataSV && SvCUR(e->dataSV)) { |
465
|
0
|
|
|
|
|
s = SvPV(e->dataSV, len); |
466
|
0
|
|
|
|
|
count = PerlIO_unread(PerlIONext(f),s,len); |
467
|
0
|
|
|
|
|
if ((STRLEN)count != len) { |
468
|
|
|
|
|
|
code = -1; |
469
|
|
|
|
|
|
} |
470
|
0
|
|
|
|
|
SvCUR_set(e->dataSV,0); |
471
|
|
|
|
|
|
} |
472
|
|
|
|
|
|
/* See if there is anything left in the buffer */ |
473
|
892
|
|
|
|
|
if (e->base.ptr < e->base.end) { |
474
|
10
|
|
|
|
|
if (e->inEncodeCall) return 0; |
475
|
|
|
|
|
|
/* Bother - have unread data. |
476
|
|
|
|
|
|
re-encode and unread() to layer below |
477
|
|
|
|
|
|
*/ |
478
|
10
|
|
|
|
|
PUSHSTACKi(PERLSI_MAGIC); |
479
|
10
|
|
|
|
|
SPAGAIN; |
480
|
10
|
|
|
|
|
ENTER; |
481
|
10
|
|
|
|
|
SAVETMPS; |
482
|
10
|
|
|
|
|
str = sv_newmortal(); |
483
|
10
|
|
|
|
|
sv_upgrade(str, SVt_PV); |
484
|
10
|
|
|
|
|
SvPV_set(str, (char*)e->base.ptr); |
485
|
10
|
|
|
|
|
SvLEN_set(str, 0); |
486
|
10
|
|
|
|
|
SvCUR_set(str, e->base.end - e->base.ptr); |
487
|
10
|
|
|
|
|
SvPOK_only(str); |
488
|
10
|
|
|
|
|
SvUTF8_on(str); |
489
|
10
|
|
|
|
|
PUSHMARK(sp); |
490
|
10
|
|
|
|
|
XPUSHs(e->enc); |
491
|
10
|
|
|
|
|
XPUSHs(str); |
492
|
10
|
|
|
|
|
XPUSHs(e->chk); |
493
|
10
|
|
|
|
|
PUTBACK; |
494
|
10
|
|
|
|
|
e->inEncodeCall = 1; |
495
|
10
|
|
|
|
|
if (call_method("encode", G_SCALAR) != 1) { |
496
|
0
|
|
|
|
|
e->inEncodeCall = 0; |
497
|
0
|
|
|
|
|
Perl_die(aTHX_ "panic: encode did not return a value"); |
498
|
|
|
|
|
|
} |
499
|
10
|
|
|
|
|
e->inEncodeCall = 0; |
500
|
10
|
|
|
|
|
SPAGAIN; |
501
|
10
|
|
|
|
|
str = POPs; |
502
|
10
|
|
|
|
|
PUTBACK; |
503
|
10
|
|
|
|
|
s = SvPV(str, len); |
504
|
10
|
|
|
|
|
count = PerlIO_unread(PerlIONext(f),s,len); |
505
|
10
|
|
|
|
|
if ((STRLEN)count != len) { |
506
|
|
|
|
|
|
code = -1; |
507
|
|
|
|
|
|
} |
508
|
10
|
|
|
|
|
FREETMPS; |
509
|
10
|
|
|
|
|
LEAVE; |
510
|
10
|
|
|
|
|
POPSTACK; |
511
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
} |
513
|
9138
|
|
|
|
|
e->base.ptr = e->base.end = e->base.buf; |
514
|
9138
|
|
|
|
|
PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); |
515
|
|
|
|
|
|
} |
516
|
9408
|
|
|
|
|
return code; |
517
|
|
|
|
|
|
} |
518
|
|
|
|
|
|
|
519
|
|
|
|
|
|
IV |
520
|
244
|
|
|
|
|
PerlIOEncode_close(pTHX_ PerlIO * f) |
521
|
|
|
|
|
|
{ |
522
|
244
|
|
|
|
|
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); |
523
|
|
|
|
|
|
IV code; |
524
|
244
|
|
|
|
|
if (PerlIOBase(f)->flags & PERLIO_F_RDBUF) { |
525
|
|
|
|
|
|
/* Discard partial character */ |
526
|
90
|
|
|
|
|
if (e->dataSV) { |
527
|
90
|
|
|
|
|
SvCUR_set(e->dataSV,0); |
528
|
|
|
|
|
|
} |
529
|
|
|
|
|
|
/* Don't back decode and unread any pending data */ |
530
|
90
|
|
|
|
|
e->base.ptr = e->base.end = e->base.buf; |
531
|
|
|
|
|
|
} |
532
|
244
|
|
|
|
|
code = PerlIOBase_close(aTHX_ f); |
533
|
244
|
|
|
|
|
if (e->bufsv) { |
534
|
|
|
|
|
|
/* This should only fire for write case */ |
535
|
238
|
|
|
|
|
if (e->base.buf && e->base.ptr > e->base.buf) { |
536
|
4
|
|
|
|
|
Perl_croak(aTHX_ "Close with partial character"); |
537
|
|
|
|
|
|
} |
538
|
234
|
|
|
|
|
SvREFCNT_dec(e->bufsv); |
539
|
234
|
|
|
|
|
e->bufsv = Nullsv; |
540
|
|
|
|
|
|
} |
541
|
240
|
|
|
|
|
e->base.buf = NULL; |
542
|
240
|
|
|
|
|
e->base.ptr = NULL; |
543
|
240
|
|
|
|
|
e->base.end = NULL; |
544
|
240
|
|
|
|
|
PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF | PERLIO_F_WRBUF); |
545
|
240
|
|
|
|
|
return code; |
546
|
|
|
|
|
|
} |
547
|
|
|
|
|
|
|
548
|
|
|
|
|
|
Off_t |
549
|
22
|
|
|
|
|
PerlIOEncode_tell(pTHX_ PerlIO * f) |
550
|
|
|
|
|
|
{ |
551
|
22
|
|
|
|
|
PerlIOBuf *b = PerlIOSelf(f, PerlIOBuf); |
552
|
|
|
|
|
|
/* Unfortunately the only way to get a position is to (re-)translate, |
553
|
|
|
|
|
|
the UTF8 we have in buffer and then ask layer below |
554
|
|
|
|
|
|
*/ |
555
|
22
|
|
|
|
|
PerlIO_flush(f); |
556
|
22
|
|
|
|
|
if (b->buf && b->ptr > b->buf) { |
557
|
0
|
|
|
|
|
Perl_croak(aTHX_ "Cannot tell at partial character"); |
558
|
|
|
|
|
|
} |
559
|
22
|
|
|
|
|
return PerlIO_tell(PerlIONext(f)); |
560
|
|
|
|
|
|
} |
561
|
|
|
|
|
|
|
562
|
|
|
|
|
|
PerlIO * |
563
|
8
|
|
|
|
|
PerlIOEncode_dup(pTHX_ PerlIO * f, PerlIO * o, |
564
|
|
|
|
|
|
CLONE_PARAMS * params, int flags) |
565
|
|
|
|
|
|
{ |
566
|
8
|
|
|
|
|
if ((f = PerlIOBase_dup(aTHX_ f, o, params, flags))) { |
567
|
8
|
|
|
|
|
PerlIOEncode *fe = PerlIOSelf(f, PerlIOEncode); |
568
|
8
|
|
|
|
|
PerlIOEncode *oe = PerlIOSelf(o, PerlIOEncode); |
569
|
8
|
|
|
|
|
if (oe->enc) { |
570
|
8
|
|
|
|
|
fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params); |
571
|
|
|
|
|
|
} |
572
|
|
|
|
|
|
} |
573
|
8
|
|
|
|
|
return f; |
574
|
|
|
|
|
|
} |
575
|
|
|
|
|
|
|
576
|
|
|
|
|
|
SSize_t |
577
|
5384
|
|
|
|
|
PerlIOEncode_write(pTHX_ PerlIO *f, const void *vbuf, Size_t count) |
578
|
|
|
|
|
|
{ |
579
|
5384
|
|
|
|
|
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode); |
580
|
5384
|
|
|
|
|
if (e->flags & NEEDS_LINES) { |
581
|
|
|
|
|
|
SSize_t done = 0; |
582
|
|
|
|
|
|
const char *ptr = (const char *) vbuf; |
583
|
1862
|
|
|
|
|
const char *end = ptr+count; |
584
|
7418
|
|
|
|
|
while (ptr < end) { |
585
|
|
|
|
|
|
const char *nl = ptr; |
586
|
373918
|
|
|
|
|
while (nl < end && *nl++ != '\n') /* empty body */; |
587
|
3694
|
|
|
|
|
done = PerlIOBuf_write(aTHX_ f, ptr, nl-ptr); |
588
|
3694
|
|
|
|
|
if (done != nl-ptr) { |
589
|
0
|
|
|
|
|
if (done > 0) { |
590
|
0
|
|
|
|
|
ptr += done; |
591
|
|
|
|
|
|
} |
592
|
|
|
|
|
|
break; |
593
|
|
|
|
|
|
} |
594
|
3694
|
|
|
|
|
ptr += done; |
595
|
3694
|
|
|
|
|
if (ptr[-1] == '\n') { |
596
|
3694
|
|
|
|
|
if (PerlIOEncode_flush(aTHX_ f) != 0) { |
597
|
|
|
|
|
|
break; |
598
|
|
|
|
|
|
} |
599
|
|
|
|
|
|
} |
600
|
|
|
|
|
|
} |
601
|
1862
|
|
|
|
|
return (SSize_t) (ptr - (const char *) vbuf); |
602
|
|
|
|
|
|
} |
603
|
|
|
|
|
|
else { |
604
|
3522
|
|
|
|
|
return PerlIOBuf_write(aTHX_ f, vbuf, count); |
605
|
|
|
|
|
|
} |
606
|
|
|
|
|
|
} |
607
|
|
|
|
|
|
|
608
|
|
|
|
|
|
PerlIO_funcs PerlIO_encode = { |
609
|
|
|
|
|
|
sizeof(PerlIO_funcs), |
610
|
|
|
|
|
|
"encoding", |
611
|
|
|
|
|
|
sizeof(PerlIOEncode), |
612
|
|
|
|
|
|
PERLIO_K_BUFFERED|PERLIO_K_DESTRUCT, |
613
|
|
|
|
|
|
PerlIOEncode_pushed, |
614
|
|
|
|
|
|
PerlIOEncode_popped, |
615
|
|
|
|
|
|
PerlIOBuf_open, |
616
|
|
|
|
|
|
NULL, /* binmode - always pop */ |
617
|
|
|
|
|
|
PerlIOEncode_getarg, |
618
|
|
|
|
|
|
PerlIOBase_fileno, |
619
|
|
|
|
|
|
PerlIOEncode_dup, |
620
|
|
|
|
|
|
PerlIOBuf_read, |
621
|
|
|
|
|
|
PerlIOBuf_unread, |
622
|
|
|
|
|
|
PerlIOEncode_write, |
623
|
|
|
|
|
|
PerlIOBuf_seek, |
624
|
|
|
|
|
|
PerlIOEncode_tell, |
625
|
|
|
|
|
|
PerlIOEncode_close, |
626
|
|
|
|
|
|
PerlIOEncode_flush, |
627
|
|
|
|
|
|
PerlIOEncode_fill, |
628
|
|
|
|
|
|
PerlIOBase_eof, |
629
|
|
|
|
|
|
PerlIOBase_error, |
630
|
|
|
|
|
|
PerlIOBase_clearerr, |
631
|
|
|
|
|
|
PerlIOBase_setlinebuf, |
632
|
|
|
|
|
|
PerlIOEncode_get_base, |
633
|
|
|
|
|
|
PerlIOBuf_bufsiz, |
634
|
|
|
|
|
|
PerlIOBuf_get_ptr, |
635
|
|
|
|
|
|
PerlIOBuf_get_cnt, |
636
|
|
|
|
|
|
PerlIOBuf_set_ptrcnt, |
637
|
|
|
|
|
|
}; |
638
|
|
|
|
|
|
#endif /* encode layer */ |
639
|
|
|
|
|
|
|
640
|
|
|
|
|
|
MODULE = PerlIO::encoding PACKAGE = PerlIO::encoding |
641
|
|
|
|
|
|
|
642
|
|
|
|
|
|
PROTOTYPES: ENABLE |
643
|
|
|
|
|
|
|
644
|
|
|
|
|
|
BOOT: |
645
|
|
|
|
|
|
{ |
646
|
72
|
|
|
|
|
SV *chk = get_sv("PerlIO::encoding::fallback", GV_ADD|GV_ADDMULTI); |
647
|
|
|
|
|
|
/* |
648
|
|
|
|
|
|
* we now "use Encode ()" here instead of |
649
|
|
|
|
|
|
* PerlIO/encoding.pm. This avoids SEGV when ":encoding()" |
650
|
|
|
|
|
|
* is invoked without prior "use Encode". -- dankogai |
651
|
|
|
|
|
|
*/ |
652
|
72
|
|
|
|
|
PUSHSTACKi(PERLSI_MAGIC); |
653
|
72
|
|
|
|
|
SPAGAIN; |
654
|
72
|
|
|
|
|
if (!get_cvs(OUR_DEFAULT_FB, 0)) { |
655
|
|
|
|
|
|
#if 0 |
656
|
|
|
|
|
|
/* This would just be an irritant now loading works */ |
657
|
|
|
|
|
|
Perl_warner(aTHX_ packWARN(WARN_IO), ":encoding without 'use Encode'"); |
658
|
|
|
|
|
|
#endif |
659
|
14
|
|
|
|
|
ENTER; |
660
|
|
|
|
|
|
/* Encode needs a lot of stack - it is likely to move ... */ |
661
|
14
|
|
|
|
|
PUTBACK; |
662
|
|
|
|
|
|
/* The SV is magically freed by load_module */ |
663
|
14
|
|
|
|
|
load_module(PERL_LOADMOD_NOIMPORT, newSVpvn("Encode", 6), Nullsv, Nullsv); |
664
|
14
|
|
|
|
|
SPAGAIN; |
665
|
14
|
|
|
|
|
LEAVE; |
666
|
|
|
|
|
|
} |
667
|
72
|
|
|
|
|
PUSHMARK(sp); |
668
|
72
|
|
|
|
|
PUTBACK; |
669
|
72
|
|
|
|
|
if (call_pv(OUR_DEFAULT_FB, G_SCALAR) != 1) { |
670
|
|
|
|
|
|
/* should never happen */ |
671
|
0
|
|
|
|
|
Perl_die(aTHX_ "%s did not return a value",OUR_DEFAULT_FB); |
672
|
|
|
|
|
|
} |
673
|
72
|
|
|
|
|
SPAGAIN; |
674
|
72
|
|
|
|
|
sv_setsv(chk, POPs); |
675
|
72
|
|
|
|
|
PUTBACK; |
676
|
|
|
|
|
|
#ifdef PERLIO_LAYERS |
677
|
72
|
|
|
|
|
PerlIO_define_layer(aTHX_ &PerlIO_encode); |
678
|
|
|
|
|
|
#endif |
679
|
72
|
|
|
|
|
POPSTACK; |
680
|
|
|
|
|
|
} |