Move ext/Encode/lib/Encode.pm to ext/Encode/Encode.pm;
[p5sagit/p5-mst-13.2.git] / ext / Encode / Encode.xs
1 #define PERL_NO_GET_CONTEXT
2
3 #include "EXTERN.h"
4 #include "perl.h"
5 #include "XSUB.h"
6 #define U8 U8
7 #include "encode.h"
8 #include "8859.h"
9 #include "EBCDIC.h"
10 #include "Symbols.h"
11
12
13 #define UNIMPLEMENTED(x,y) y x (SV *sv, char *encoding) {dTHX;   \
14                          Perl_croak(aTHX_ "panic_unimplemented"); \
15                          return (y)0; /* fool picky compilers */ \
16                          }
17 UNIMPLEMENTED(_encoded_utf8_to_bytes, I32)
18 UNIMPLEMENTED(_encoded_bytes_to_utf8, I32)
19
20 #if defined(USE_PERLIO) && !defined(USE_SFIO)
21 /* Define an encoding "layer" in the perliol.h sense.
22    The layer defined here "inherits" in an object-oriented sense from the
23    "perlio" layer with its PerlIOBuf_* "methods".
24    The implementation is particularly efficient as until Encode settles down
25    there is no point in tryint to tune it.
26
27    The layer works by overloading the "fill" and "flush" methods.
28
29    "fill" calls "SUPER::fill" in perl terms, then calls the encode OO perl API
30    to convert the encoded data to UTF-8 form, then copies it back to the
31    buffer. The "base class's" read methods then see the UTF-8 data.
32
33    "flush" transforms the UTF-8 data deposited by the "base class's write
34    method in the buffer back into the encoded form using the encode OO perl API,
35    then copies data back into the buffer and calls "SUPER::flush.
36
37    Note that "flush" is _also_ called for read mode - we still do the (back)-translate
38    so that the the base class's "flush" sees the correct number of encoded chars
39    for positioning the seek pointer. (This double translation is the worst performance
40    issue - particularly with all-perl encode engine.)
41
42 */
43
44
45 #include "perliol.h"
46
47 typedef struct
48 {
49  PerlIOBuf      base;         /* PerlIOBuf stuff */
50  SV *           bufsv;
51  SV *           enc;
52 } PerlIOEncode;
53
54 SV *
55 PerlIOEncode_getarg(pTHX_ PerlIO *f, CLONE_PARAMS *param, int flags)
56 {
57  PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
58  SV *sv = &PL_sv_undef;
59  if (e->enc)
60   {
61    dSP;
62    ENTER;
63    SAVETMPS;
64    PUSHMARK(sp);
65    XPUSHs(e->enc);
66    PUTBACK;
67    if (perl_call_method("name",G_SCALAR) == 1)
68     {
69      SPAGAIN;
70      sv = newSVsv(POPs);
71      PUTBACK;
72     }
73   }
74  return sv;
75 }
76
77 IV
78 PerlIOEncode_pushed(pTHX_ PerlIO *f, const char *mode, SV *arg)
79 {
80  PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
81  dSP;
82  IV code;
83  code = PerlIOBuf_pushed(aTHX_ f,mode,Nullsv);
84  ENTER;
85  SAVETMPS;
86  PUSHMARK(sp);
87  XPUSHs(arg);
88  PUTBACK;
89  if (perl_call_pv("Encode::find_encoding",G_SCALAR) != 1)
90   {
91    /* should never happen */
92    Perl_die(aTHX_ "Encode::find_encoding did not return a value");
93    return -1;
94   }
95  SPAGAIN;
96  e->enc = POPs;
97  PUTBACK;
98  if (!SvROK(e->enc))
99   {
100    e->enc = Nullsv;
101    errno  = EINVAL;
102    Perl_warner(aTHX_ WARN_IO, "Cannot find encoding \"%"SVf"\"", arg);
103    code = -1;
104   }
105  else
106   {
107    SvREFCNT_inc(e->enc);
108    PerlIOBase(f)->flags |= PERLIO_F_UTF8;
109   }
110  FREETMPS;
111  LEAVE;
112  return code;
113 }
114
115 IV
116 PerlIOEncode_popped(pTHX_ PerlIO *f)
117 {
118  PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
119  if (e->enc)
120   {
121    SvREFCNT_dec(e->enc);
122    e->enc = Nullsv;
123   }
124  if (e->bufsv)
125   {
126    SvREFCNT_dec(e->bufsv);
127    e->bufsv = Nullsv;
128   }
129  return 0;
130 }
131
132 STDCHAR *
133 PerlIOEncode_get_base(pTHX_ PerlIO *f)
134 {
135  PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
136  if (!e->base.bufsiz)
137   e->base.bufsiz = 1024;
138  if (!e->bufsv)
139   {
140    e->bufsv = newSV(e->base.bufsiz);
141    sv_setpvn(e->bufsv,"",0);
142   }
143  e->base.buf = (STDCHAR *)SvPVX(e->bufsv);
144  if (!e->base.ptr)
145   e->base.ptr = e->base.buf;
146  if (!e->base.end)
147   e->base.end = e->base.buf;
148  if (e->base.ptr < e->base.buf || e->base.ptr > e->base.buf+SvLEN(e->bufsv))
149   {
150    Perl_warn(aTHX_ " ptr %p(%p)%p",
151              e->base.buf,e->base.ptr,e->base.buf+SvLEN(e->bufsv));
152    abort();
153   }
154  if (SvLEN(e->bufsv) < e->base.bufsiz)
155   {
156    SSize_t poff = e->base.ptr - e->base.buf;
157    SSize_t eoff = e->base.end - e->base.buf;
158    e->base.buf  = (STDCHAR *)SvGROW(e->bufsv,e->base.bufsiz);
159    e->base.ptr  = e->base.buf + poff;
160    e->base.end  = e->base.buf + eoff;
161   }
162  if (e->base.ptr < e->base.buf || e->base.ptr > e->base.buf+SvLEN(e->bufsv))
163   {
164    Perl_warn(aTHX_ " ptr %p(%p)%p",
165              e->base.buf,e->base.ptr,e->base.buf+SvLEN(e->bufsv));
166    abort();
167   }
168  return e->base.buf;
169 }
170
171 IV
172 PerlIOEncode_fill(pTHX_ PerlIO *f)
173 {
174  PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
175  dSP;
176  IV code;
177  code = PerlIOBuf_fill(aTHX_ f);
178  if (code == 0)
179   {
180    SV *uni;
181    STRLEN len;
182    char *s;
183    /* Set SV that is the buffer to be buf..ptr */
184    SvCUR_set(e->bufsv, e->base.end - e->base.buf);
185    SvUTF8_off(e->bufsv);
186    ENTER;
187    SAVETMPS;
188    PUSHMARK(sp);
189    XPUSHs(e->enc);
190    XPUSHs(e->bufsv);
191    XPUSHs(&PL_sv_yes);
192    PUTBACK;
193    if (perl_call_method("decode",G_SCALAR) != 1)
194     code = -1;
195    SPAGAIN;
196    uni = POPs;
197    PUTBACK;
198    /* Now get translated string (forced to UTF-8) and copy back to buffer
199       don't use sv_setsv as that may "steal" PV from returned temp
200       and so free() our known-large-enough buffer.
201       sv_setpvn() should do but let us do it long hand.
202     */
203    s = SvPVutf8(uni,len);
204    if (s != SvPVX(e->bufsv))
205     {
206      e->base.buf = (STDCHAR *)SvGROW(e->bufsv,len);
207      Move(s,e->base.buf,len,char);
208      SvCUR_set(e->bufsv,len);
209     }
210    SvUTF8_on(e->bufsv);
211    e->base.end    = e->base.buf+len;
212    e->base.ptr    = e->base.buf;
213    FREETMPS;
214    LEAVE;
215   }
216  return code;
217 }
218
219 IV
220 PerlIOEncode_flush(pTHX_ PerlIO *f)
221 {
222  PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
223  IV code = 0;
224  if (e->bufsv && (PerlIOBase(f)->flags & (PERLIO_F_RDBUF|PERLIO_F_WRBUF))
225      &&(e->base.ptr > e->base.buf)
226     )
227   {
228    dSP;
229    SV *str;
230    char *s;
231    STRLEN len;
232    SSize_t left = 0;
233    if (PerlIOBase(f)->flags & PERLIO_F_RDBUF)
234     {
235      /* This is really just a flag to see if we took all the data, if
236         we did PerlIOBase_flush avoids a seek to lower layer.
237         Need to revisit if we start getting clever with unreads or seeks-in-buffer
238       */
239      left = e->base.end - e->base.ptr;
240     }
241    ENTER;
242    SAVETMPS;
243    PUSHMARK(sp);
244    XPUSHs(e->enc);
245    SvCUR_set(e->bufsv, e->base.ptr - e->base.buf);
246    SvUTF8_on(e->bufsv);
247    XPUSHs(e->bufsv);
248    XPUSHs(&PL_sv_yes);
249    PUTBACK;
250    if (perl_call_method("encode",G_SCALAR) != 1)
251     code = -1;
252    SPAGAIN;
253    str = POPs;
254    PUTBACK;
255    s = SvPV(str,len);
256    if (s != SvPVX(e->bufsv))
257     {
258      e->base.buf = (STDCHAR *)SvGROW(e->bufsv,len);
259      Move(s,e->base.buf,len,char);
260      SvCUR_set(e->bufsv,len);
261     }
262    SvUTF8_off(e->bufsv);
263    e->base.ptr = e->base.buf+len;
264    /* restore end != ptr as inequality is used by PerlIOBuf_flush in read case */
265    e->base.end = e->base.ptr + left;
266    FREETMPS;
267    LEAVE;
268    if (PerlIOBuf_flush(aTHX_ f) != 0)
269     code = -1;
270   }
271  return code;
272 }
273
274 IV
275 PerlIOEncode_close(pTHX_ PerlIO *f)
276 {
277  PerlIOEncode *e = PerlIOSelf(f,PerlIOEncode);
278  IV code = PerlIOBase_close(aTHX_ f);
279  if (e->bufsv)
280   {
281    SvREFCNT_dec(e->bufsv);
282    e->bufsv = Nullsv;
283   }
284  e->base.buf = NULL;
285  e->base.ptr = NULL;
286  e->base.end = NULL;
287  PerlIOBase(f)->flags &= ~(PERLIO_F_RDBUF|PERLIO_F_WRBUF);
288  return code;
289 }
290
291 Off_t
292 PerlIOEncode_tell(pTHX_ PerlIO *f)
293 {
294  PerlIOBuf *b = PerlIOSelf(f,PerlIOBuf);
295  /* Unfortunately the only way to get a postion is to back-translate,
296     the UTF8-bytes we have buf..ptr and adjust accordingly.
297     But we will try and save any unread data in case stream
298     is un-seekable.
299   */
300  if ((PerlIOBase(f)->flags & PERLIO_F_RDBUF) && b->ptr < b->end)
301   {
302    Size_t count = b->end - b->ptr;
303    PerlIO_push(aTHX_ f,&PerlIO_pending,"r",Nullsv);
304    /* Save what we have left to read */
305    PerlIOSelf(f,PerlIOBuf)->bufsiz = count;
306    PerlIO_unread(f,b->ptr,count);
307    /* There isn't any unread data - we just saved it - so avoid the lower seek */
308    b->end = b->ptr;
309    /* Flush ourselves - now one layer down,
310       this does the back translate and adjusts position
311     */
312    PerlIO_flush(PerlIONext(f));
313    /* Set position of the saved data */
314    PerlIOSelf(f,PerlIOBuf)->posn = b->posn;
315   }
316  else
317   {
318    PerlIO_flush(f);
319   }
320  return b->posn;
321 }
322
323 PerlIO *
324 PerlIOEncode_dup(pTHX_ PerlIO *f, PerlIO *o, CLONE_PARAMS *params, int flags)
325 {
326  if ((f = PerlIOBase_dup(aTHX_ f, o, params, flags)))
327   {
328    PerlIOEncode *fe = PerlIOSelf(f,PerlIOEncode);
329    PerlIOEncode *oe = PerlIOSelf(o,PerlIOEncode);
330    if (oe->enc)
331     {
332      fe->enc = PerlIO_sv_dup(aTHX_ oe->enc, params);
333     }
334   }
335  return f;
336 }
337
338 PerlIO_funcs PerlIO_encode = {
339  "encoding",
340  sizeof(PerlIOEncode),
341  PERLIO_K_BUFFERED,
342  PerlIOEncode_pushed,
343  PerlIOEncode_popped,
344  PerlIOBuf_open,
345  PerlIOEncode_getarg,
346  PerlIOBase_fileno,
347  PerlIOEncode_dup,
348  PerlIOBuf_read,
349  PerlIOBuf_unread,
350  PerlIOBuf_write,
351  PerlIOBuf_seek,
352  PerlIOEncode_tell,
353  PerlIOEncode_close,
354  PerlIOEncode_flush,
355  PerlIOEncode_fill,
356  PerlIOBase_eof,
357  PerlIOBase_error,
358  PerlIOBase_clearerr,
359  PerlIOBase_setlinebuf,
360  PerlIOEncode_get_base,
361  PerlIOBuf_bufsiz,
362  PerlIOBuf_get_ptr,
363  PerlIOBuf_get_cnt,
364  PerlIOBuf_set_ptrcnt,
365 };
366 #endif /* encode layer */
367
368 void
369 Encode_XSEncoding(pTHX_ encode_t *enc)
370 {
371  dSP;
372  HV *stash = gv_stashpv("Encode::XS", TRUE);
373  SV *sv    = sv_bless(newRV_noinc(newSViv(PTR2IV(enc))),stash);
374  int i = 0;
375  PUSHMARK(sp);
376  XPUSHs(sv);
377  while (enc->name[i])
378   {
379    const char *name = enc->name[i++];
380    XPUSHs(sv_2mortal(newSVpvn(name,strlen(name))));
381   }
382  PUTBACK;
383  call_pv("Encode::define_encoding",G_DISCARD);
384  SvREFCNT_dec(sv);
385 }
386
387 void call_failure (SV *routine, U8* done, U8* dest, U8* orig) {}
388
389 static SV *
390 encode_method(pTHX_ encode_t *enc, encpage_t *dir, SV *src, int check)
391 {
392  STRLEN slen;
393  U8 *s = (U8 *) SvPV(src,slen);
394  SV *dst = sv_2mortal(newSV(2*slen+1));
395  if (slen)
396   {
397    U8 *d = (U8 *) SvGROW(dst, 2*slen+1);
398    STRLEN dlen = SvLEN(dst);
399    int code;
400    while ((code = do_encode(dir,s,&slen,d,dlen,&dlen,!check)))
401     {
402      SvCUR_set(dst,dlen);
403      SvPOK_on(dst);
404
405      if (code == ENCODE_FALLBACK)
406       break;
407
408      switch(code)
409       {
410        case ENCODE_NOSPACE:
411         {
412          STRLEN need = dlen + UTF8_MAXLEN * 128; /* 128 is too big or small? */
413          d = (U8 *) SvGROW(dst, need);
414          if (dlen >= SvLEN(dst))
415           {
416            Perl_croak(aTHX_ "Destination couldn't be grown (the need may be miscalculated).");
417           }
418          dlen = SvLEN(dst);
419          slen = SvCUR(src);
420          break;
421         }
422
423        case ENCODE_NOREP:
424         if (dir == enc->f_utf8)
425          {
426           if (!check && ckWARN_d(WARN_UTF8))
427            {
428             STRLEN clen;
429             UV ch = utf8n_to_uvuni(s+slen,(SvCUR(src)-slen),&clen,0);
430             Perl_warner(aTHX_ WARN_UTF8, "\"\\N{U+%"UVxf"}\" does not map to %s", ch, enc->name[0]);
431             /* FIXME: Skip over the character, copy in replacement and continue
432              * but that is messy so for now just fail.
433              */
434             return &PL_sv_undef;
435            }
436           else
437            {
438             return &PL_sv_undef;
439            }
440          }
441         else
442          {
443           /* UTF-8 is supposed to be "Universal" so should not happen */
444           Perl_croak(aTHX_ "%s '%.*s' does not map to UTF-8",
445                  enc->name[0], (int)(SvCUR(src)-slen),s+slen);
446          }
447         break;
448
449        case ENCODE_PARTIAL:
450          if (!check && ckWARN_d(WARN_UTF8))
451           {
452            Perl_warner(aTHX_ WARN_UTF8, "Partial %s character",
453                        (dir == enc->f_utf8) ? "UTF-8" : enc->name[0]);
454           }
455          return &PL_sv_undef;
456
457        default:
458         Perl_croak(aTHX_ "Unexpected code %d converting %s %s",
459                  code, (dir == enc->f_utf8) ? "to" : "from",enc->name[0]);
460         return &PL_sv_undef;
461       }
462     }
463    SvCUR_set(dst,dlen);
464    SvPOK_on(dst);
465    if (check)
466     {
467      if (slen < SvCUR(src))
468       {
469        Move(s+slen,s,SvCUR(src)-slen,U8);
470       }
471      SvCUR_set(src,SvCUR(src)-slen);
472     }
473   }
474  else
475   {
476    SvCUR_set(dst,slen);
477    SvPOK_on(dst);
478   }
479  return dst;
480 }
481
482 MODULE = Encode         PACKAGE = Encode::XS    PREFIX = Method_
483
484 PROTOTYPES: ENABLE
485
486 void
487 Method_decode(obj,src,check = FALSE)
488 SV *    obj
489 SV *    src
490 bool    check
491 CODE:
492  {
493   encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
494   ST(0) = encode_method(aTHX_ enc, enc->t_utf8, src, check);
495   SvUTF8_on(ST(0));
496   XSRETURN(1);
497  }
498
499 void
500 Method_encode(obj,src,check = FALSE)
501 SV *    obj
502 SV *    src
503 bool    check
504 CODE:
505  {
506   encode_t *enc = INT2PTR(encode_t *, SvIV(SvRV(obj)));
507   sv_utf8_upgrade(src);
508   ST(0) = encode_method(aTHX_ enc, enc->f_utf8, src, check);
509   XSRETURN(1);
510  }
511
512 MODULE = Encode         PACKAGE = Encode
513
514 PROTOTYPES: ENABLE
515
516 I32
517 _bytes_to_utf8(sv, ...)
518         SV *    sv
519       CODE:
520         {
521           SV * encoding = items == 2 ? ST(1) : Nullsv;
522
523           if (encoding)
524             RETVAL = _encoded_bytes_to_utf8(sv, SvPV_nolen(encoding));
525           else {
526             STRLEN len;
527             U8*    s = (U8*)SvPV(sv, len);
528             U8*    converted;
529
530             converted = bytes_to_utf8(s, &len); /* This allocs */
531             sv_setpvn(sv, (char *)converted, len);
532             SvUTF8_on(sv); /* XXX Should we? */
533             Safefree(converted);                /* ... so free it */
534             RETVAL = len;
535           }
536         }
537       OUTPUT:
538         RETVAL
539
540 I32
541 _utf8_to_bytes(sv, ...)
542         SV *    sv
543       CODE:
544         {
545           SV * to    = items > 1 ? ST(1) : Nullsv;
546           SV * check = items > 2 ? ST(2) : Nullsv;
547
548           if (to)
549             RETVAL = _encoded_utf8_to_bytes(sv, SvPV_nolen(to));
550           else {
551             STRLEN len;
552             U8 *s = (U8*)SvPV(sv, len);
553
554             RETVAL = 0;
555             if (SvTRUE(check)) {
556               /* Must do things the slow way */
557               U8 *dest;
558               U8 *src  = (U8*)savepv((char *)s); /* We need a copy to pass to check() */
559               U8 *send = s + len;
560
561               New(83, dest, len, U8); /* I think */
562
563               while (s < send) {
564                 if (*s < 0x80)
565                   *dest++ = *s++;
566                 else {
567                   STRLEN ulen;
568                   UV uv = *s++;
569
570                   /* Have to do it all ourselves because of error routine,
571                      aargh. */
572                   if (!(uv & 0x40))
573                     goto failure;
574                   if      (!(uv & 0x20)) { ulen = 2;  uv &= 0x1f; }
575                   else if (!(uv & 0x10)) { ulen = 3;  uv &= 0x0f; }
576                   else if (!(uv & 0x08)) { ulen = 4;  uv &= 0x07; }
577                   else if (!(uv & 0x04)) { ulen = 5;  uv &= 0x03; }
578                   else if (!(uv & 0x02)) { ulen = 6;  uv &= 0x01; }
579                   else if (!(uv & 0x01)) { ulen = 7;  uv = 0; }
580                   else                   { ulen = 13; uv = 0; }
581                 
582                   /* Note change to utf8.c variable naming, for variety */
583                   while (ulen--) {
584                     if ((*s & 0xc0) != 0x80)
585                       goto failure;
586                 
587                     else
588                       uv = (uv << 6) | (*s++ & 0x3f);
589                   }
590                   if (uv > 256) {
591                   failure:
592                     call_failure(check, s, dest, src);
593                     /* Now what happens? */
594                   }
595                   *dest++ = (U8)uv;
596                }
597                }
598             } else
599               RETVAL = (utf8_to_bytes(s, &len) ? len : 0);
600           }
601         }
602       OUTPUT:
603         RETVAL
604
605 bool
606 is_utf8(sv, check = FALSE)
607 SV *    sv
608 bool    check
609       CODE:
610         {
611           if (SvGMAGICAL(sv)) /* it could be $1, for example */
612             sv = newSVsv(sv); /* GMAGIG will be done */
613           if (SvPOK(sv)) {
614             RETVAL = SvUTF8(sv) ? TRUE : FALSE;
615             if (RETVAL &&
616                 check  &&
617                 !is_utf8_string((U8*)SvPVX(sv), SvCUR(sv)))
618               RETVAL = FALSE;
619           } else {
620             RETVAL = FALSE;
621           }
622           if (sv != ST(0))
623             SvREFCNT_dec(sv); /* it was a temp copy */
624         }
625       OUTPUT:
626         RETVAL
627
628 SV *
629 _utf8_on(sv)
630         SV *    sv
631       CODE:
632         {
633           if (SvPOK(sv)) {
634             SV *rsv = newSViv(SvUTF8(sv));
635             RETVAL = rsv;
636             SvUTF8_on(sv);
637           } else {
638             RETVAL = &PL_sv_undef;
639           }
640         }
641       OUTPUT:
642         RETVAL
643
644 SV *
645 _utf8_off(sv)
646         SV *    sv
647       CODE:
648         {
649           if (SvPOK(sv)) {
650             SV *rsv = newSViv(SvUTF8(sv));
651             RETVAL = rsv;
652             SvUTF8_off(sv);
653           } else {
654             RETVAL = &PL_sv_undef;
655           }
656         }
657       OUTPUT:
658         RETVAL
659
660 BOOT:
661 {
662 #if defined(USE_PERLIO) && !defined(USE_SFIO)
663  PerlIO_define_layer(aTHX_ &PerlIO_encode);
664 #endif
665 #include "8859.def"
666 #include "EBCDIC.def"
667 #include "Symbols.def"
668 }