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