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