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