[perl #125924] allow op/infnan.t to pass on Win32 gcc
[perl.git] / cpan / Encode / Unicode / Unicode.xs
1 /*
2  $Id: Unicode.xs,v 2.12 2015/06/25 00:49:23 dankogai Exp $
3  */
4
5 #define PERL_NO_GET_CONTEXT
6 #include "EXTERN.h"
7 #include "perl.h"
8 #include "XSUB.h"
9 #include "../Encode/encode.h"
10
11 #define FBCHAR                  0xFFFd
12 #define BOM_BE                  0xFeFF
13 #define BOM16LE                 0xFFFe
14 #define BOM32LE                 0xFFFe0000
15 #define issurrogate(x)          (0xD800 <= (x)  && (x) <= 0xDFFF )
16 #define isHiSurrogate(x)        (0xD800 <= (x)  && (x) <  0xDC00 )
17 #define isLoSurrogate(x)        (0xDC00 <= (x)  && (x) <= 0xDFFF )
18 #define invalid_ucs2(x)         ( issurrogate(x) || 0xFFFF < (x) )
19
20 /* For pre-5.14 source compatibility */
21 #ifndef UNICODE_WARN_ILLEGAL_INTERCHANGE
22 #   define UNICODE_WARN_ILLEGAL_INTERCHANGE 0
23 #   define UTF8_DISALLOW_SURROGATE 0
24 #   define UTF8_WARN_SURROGATE 0
25 #   define UTF8_DISALLOW_FE_FF 0
26 #   define UTF8_WARN_FE_FF 0
27 #   define UTF8_WARN_NONCHAR 0
28 #endif
29
30 #define PERLIO_BUFSIZ 1024 /* XXX value comes from PerlIOEncode_get_base */
31
32 /* Avoid wasting too much space in the result buffer */
33 /* static void */
34 /* shrink_buffer(SV *result) */
35 /* { */
36 /*     if (SvLEN(result) > 42 + SvCUR(result)) { */
37 /*      char *buf; */
38 /*      STRLEN len = 1 + SvCUR(result); /\* include the NUL byte *\/ */
39 /*      New(0, buf, len, char); */
40 /*      Copy(SvPVX(result), buf, len, char); */
41 /*      Safefree(SvPVX(result)); */
42 /*      SvPV_set(result, buf); */
43 /*      SvLEN_set(result, len); */
44 /*     } */
45 /* } */
46
47 #define shrink_buffer(result) { \
48     if (SvLEN(result) > 42 + SvCUR(result)) { \
49         char *newpv; \
50         STRLEN newlen = 1 + SvCUR(result); /* include the NUL byte */ \
51         New(0, newpv, newlen, char); \
52         Copy(SvPVX(result), newpv, newlen, char); \
53         Safefree(SvPVX(result)); \
54         SvPV_set(result, newpv); \
55         SvLEN_set(result, newlen); \
56     } \
57 }
58
59 static UV
60 enc_unpack(pTHX_ U8 **sp, U8 *e, STRLEN size, U8 endian)
61 {
62     U8 *s = *sp;
63     UV v = 0;
64     if (s+size > e) {
65         croak("Partial character %c",(char) endian);
66     }
67     switch(endian) {
68     case 'N':
69         v = *s++;
70         v = (v << 8) | *s++;
71     case 'n':
72         v = (v << 8) | *s++;
73         v = (v << 8) | *s++;
74         break;
75     case 'V':
76     case 'v':
77         v |= *s++;
78         v |= (*s++ << 8);
79         if (endian == 'v')
80             break;
81         v |= (*s++ << 16);
82         v |= ((UV)*s++ << 24);
83         break;
84     default:
85         croak("Unknown endian %c",(char) endian);
86         break;
87     }
88     *sp = s;
89     return v;
90 }
91
92 void
93 enc_pack(pTHX_ SV *result, STRLEN size, U8 endian, UV value)
94 {
95     U8 *d = (U8 *) SvPV_nolen(result);
96
97     switch(endian) {
98     case 'v':
99     case 'V':
100         d += SvCUR(result);
101         SvCUR_set(result,SvCUR(result)+size);
102         while (size--) {
103             *d++ = (U8)(value & 0xFF);
104             value >>= 8;
105         }
106         break;
107     case 'n':
108     case 'N':
109         SvCUR_set(result,SvCUR(result)+size);
110         d += SvCUR(result);
111         while (size--) {
112             *--d = (U8)(value & 0xFF);
113             value >>= 8;
114         }
115         break;
116     default:
117         croak("Unknown endian %c",(char) endian);
118         break;
119     }
120 }
121
122 MODULE = Encode::Unicode PACKAGE = Encode::Unicode
123
124 PROTOTYPES: DISABLE
125
126 #define attr(k, l)  (hv_exists((HV *)SvRV(obj),k,l) ? \
127     *hv_fetch((HV *)SvRV(obj),k,l,0) : &PL_sv_undef)
128 #define attr_true(k, l)  (hv_exists((HV *)SvRV(obj),k,l) ? \
129     SvTRUE(*hv_fetch((HV *)SvRV(obj),k,l,0)) : FALSE)
130
131 void
132 decode_xs(obj, str, check = 0)
133 SV *    obj
134 SV *    str
135 IV      check
136 CODE:
137 {
138     U8 endian    = *((U8 *)SvPV_nolen(attr("endian", 6)));
139     int size     = SvIV(attr("size", 4));
140     int ucs2     = -1; /* only needed in the event of surrogate pairs */
141     SV *result   = newSVpvn("",0);
142     STRLEN usize = (size > 0 ? size : 1); /* protect against rogue size<=0 */
143     STRLEN ulen;
144     STRLEN resultbuflen;
145     U8 *resultbuf;
146     U8 *s = (U8 *)SvPVbyte(str,ulen);
147     U8 *e = (U8 *)SvEND(str);
148     /* Optimise for the common case of being called from PerlIOEncode_fill()
149        with a standard length buffer. In this case the result SV's buffer is
150        only used temporarily, so we can afford to allocate the maximum needed
151        and not care about unused space. */
152     const bool temp_result = (ulen == PERLIO_BUFSIZ);
153
154     ST(0) = sv_2mortal(result);
155     SvUTF8_on(result);
156
157     if (!endian && s+size <= e) {
158         UV bom;
159         endian = (size == 4) ? 'N' : 'n';
160         bom = enc_unpack(aTHX_ &s,e,size,endian);
161         if (bom != BOM_BE) {
162             if (bom == BOM16LE) {
163                 endian = 'v';
164             }
165             else if (bom == BOM32LE) {
166                 endian = 'V';
167             }
168             else {
169                 croak("%"SVf":Unrecognised BOM %"UVxf,
170                       *hv_fetch((HV *)SvRV(obj),"Name",4,0),
171                       bom);
172             }
173         }
174 #if 1
175         /* Update endian for next sequence */
176         if (attr_true("renewed", 7)) {
177             hv_store((HV *)SvRV(obj),"endian",6,newSVpv((char *)&endian,1),0);
178         }
179 #endif
180     }
181
182     if (temp_result) {
183         resultbuflen = 1 + ulen/usize * UTF8_MAXLEN;
184     } else {
185         /* Preallocate the buffer to the minimum possible space required. */
186         resultbuflen = ulen/usize + UTF8_MAXLEN + 1;
187     }
188     resultbuf = (U8 *) SvGROW(result, resultbuflen);
189
190     while (s < e && s+size <= e) {
191         UV ord = enc_unpack(aTHX_ &s,e,size,endian);
192         U8 *d;
193         if (issurrogate(ord)) {
194             if (ucs2 == -1) {
195                 ucs2 = attr_true("ucs2", 4);
196             }
197             if (ucs2 || size == 4) {
198                 if (check) {
199                     croak("%"SVf":no surrogates allowed %"UVxf,
200                           *hv_fetch((HV *)SvRV(obj),"Name",4,0),
201                           ord);
202                 }
203                 ord = FBCHAR;
204             }
205             else {
206                 UV lo;
207                 if (!isHiSurrogate(ord)) {
208                     if (check) {
209                         croak("%"SVf":Malformed HI surrogate %"UVxf,
210                               *hv_fetch((HV *)SvRV(obj),"Name",4,0),
211                               ord);
212                     }
213                     else {
214                         ord = FBCHAR;
215                     }
216                 }
217                 else if (s+size > e) {
218                     if (check) {
219                         if (check & ENCODE_STOP_AT_PARTIAL) {
220                              s -= size;
221                              break;
222                         }
223                         else {
224                              croak("%"SVf":Malformed HI surrogate %"UVxf,
225                                    *hv_fetch((HV *)SvRV(obj),"Name",4,0),
226                                    ord);
227                         }
228                     }
229                     else {
230                         ord = FBCHAR;
231                     }
232                 }
233                 else {
234                     lo = enc_unpack(aTHX_ &s,e,size,endian);
235                     if (!isLoSurrogate(lo)) {
236                         if (check) {
237                             croak("%"SVf":Malformed LO surrogate %"UVxf,
238                                   *hv_fetch((HV *)SvRV(obj),"Name",4,0),
239                                   ord);
240                         }
241                         else {
242                             s -= size;
243                             ord = FBCHAR;
244                         }
245                     }
246                     else {
247                         ord = 0x10000 + ((ord - 0xD800) << 10) + (lo - 0xDC00);
248                     }
249                 }
250             }
251         }
252
253         if ((ord & 0xFFFE) == 0xFFFE || (ord >= 0xFDD0 && ord <= 0xFDEF)) {
254             if (check) {
255                 croak("%"SVf":Unicode character %"UVxf" is illegal",
256                       *hv_fetch((HV *)SvRV(obj),"Name",4,0),
257                       ord);
258             } else {
259                 ord = FBCHAR;
260             }
261         }
262
263         if (resultbuflen < SvCUR(result) + UTF8_MAXLEN + 1) {
264             /* Do not allocate >8Mb more than the minimum needed.
265                This prevents allocating too much in the rogue case of a large
266                input consisting initially of long sequence uft8-byte unicode
267                chars followed by single utf8-byte chars. */
268             /* +1 
269                fixes  Unicode.xs!decode_xs n-byte heap-overflow
270               */
271             STRLEN remaining = (e - s)/usize + 1; /* +1 to avoid the leak */
272             STRLEN max_alloc = remaining + (8*1024*1024);
273             STRLEN est_alloc = remaining * UTF8_MAXLEN;
274             STRLEN newlen = SvLEN(result) + /* min(max_alloc, est_alloc) */
275                 (est_alloc > max_alloc ? max_alloc : est_alloc);
276             resultbuf = (U8 *) SvGROW(result, newlen);
277             resultbuflen = SvLEN(result);
278         }
279
280         d = uvuni_to_utf8_flags(resultbuf+SvCUR(result), ord,
281                                             UNICODE_WARN_ILLEGAL_INTERCHANGE);
282         SvCUR_set(result, d - (U8 *)SvPVX(result));
283     }
284
285     if (s < e) {
286         /* unlikely to happen because it's fixed-length -- dankogai */
287         if (check & ENCODE_WARN_ON_ERR) {
288             Perl_warner(aTHX_ packWARN(WARN_UTF8),"%"SVf":Partial character",
289                         *hv_fetch((HV *)SvRV(obj),"Name",4,0));
290         }
291     }
292     if (check && !(check & ENCODE_LEAVE_SRC)) {
293         if (s < e) {
294             Move(s,SvPVX(str),e-s,U8);
295             SvCUR_set(str,(e-s));
296         }
297         else {
298             SvCUR_set(str,0);
299         }
300         *SvEND(str) = '\0';
301     }
302
303     if (!temp_result) shrink_buffer(result);
304     if (SvTAINTED(str)) SvTAINTED_on(result); /* propagate taintedness */
305     XSRETURN(1);
306 }
307
308 void
309 encode_xs(obj, utf8, check = 0)
310 SV *    obj
311 SV *    utf8
312 IV      check
313 CODE:
314 {
315     U8 endian = *((U8 *)SvPV_nolen(attr("endian", 6)));
316     const int size = SvIV(attr("size", 4));
317     int ucs2 = -1; /* only needed if there is invalid_ucs2 input */
318     const STRLEN usize = (size > 0 ? size : 1);
319     SV *result = newSVpvn("", 0);
320     STRLEN ulen;
321     U8 *s = (U8 *) SvPVutf8(utf8, ulen);
322     const U8 *e = (U8 *) SvEND(utf8);
323     /* Optimise for the common case of being called from PerlIOEncode_flush()
324        with a standard length buffer. In this case the result SV's buffer is
325        only used temporarily, so we can afford to allocate the maximum needed
326        and not care about unused space. */
327     const bool temp_result = (ulen == PERLIO_BUFSIZ);
328
329     ST(0) = sv_2mortal(result);
330
331     /* Preallocate the result buffer to the maximum possible size.
332        ie. assume each UTF8 byte is 1 character.
333        Then shrink the result's buffer if necesary at the end. */
334     SvGROW(result, ((ulen+1) * usize));
335
336     if (!endian) {
337         endian = (size == 4) ? 'N' : 'n';
338         enc_pack(aTHX_ result,size,endian,BOM_BE);
339 #if 1
340         /* Update endian for next sequence */
341         if (attr_true("renewed", 7)) {
342             hv_store((HV *)SvRV(obj),"endian",6,newSVpv((char *)&endian,1),0);
343         }
344 #endif
345     }
346     while (s < e && s+UTF8SKIP(s) <= e) {
347         STRLEN len;
348         UV ord = utf8n_to_uvuni(s, e-s, &len, (UTF8_DISALLOW_SURROGATE
349                                                |UTF8_WARN_SURROGATE
350                                                |UTF8_DISALLOW_FE_FF
351                                                |UTF8_WARN_FE_FF
352                                                |UTF8_WARN_NONCHAR));
353         s += len;
354         if (size != 4 && invalid_ucs2(ord)) {
355             if (!issurrogate(ord)) {
356                 if (ucs2 == -1) {
357                     ucs2 = attr_true("ucs2", 4);
358                 }
359                 if (ucs2 || ord > 0x10FFFF) {
360                     if (check) {
361                         croak("%"SVf":code point \"\\x{%"UVxf"}\" too high",
362                                   *hv_fetch((HV *)SvRV(obj),"Name",4,0),ord);
363                     }
364                     enc_pack(aTHX_ result,size,endian,FBCHAR);
365                 } else {
366                     UV hi = ((ord - 0x10000) >> 10)   + 0xD800;
367                     UV lo = ((ord - 0x10000) & 0x3FF) + 0xDC00;
368                     enc_pack(aTHX_ result,size,endian,hi);
369                     enc_pack(aTHX_ result,size,endian,lo);
370                 }
371             }
372             else {
373                 /* not supposed to happen */
374                 enc_pack(aTHX_ result,size,endian,FBCHAR);
375             }
376         }
377         else {
378             enc_pack(aTHX_ result,size,endian,ord);
379         }
380     }
381     if (s < e) {
382         /* UTF-8 partial char happens often on PerlIO.
383            Since this is okay and normal, we do not warn.
384            But this is critical when you choose to LEAVE_SRC
385            in which case we die */
386         if (check & (ENCODE_DIE_ON_ERR|ENCODE_LEAVE_SRC)) {
387             Perl_croak(aTHX_ "%"SVf":partial character is not allowed "
388                        "when CHECK = 0x%" UVuf,
389                        *hv_fetch((HV *)SvRV(obj),"Name",4,0), check);
390         }
391     }
392     if (check && !(check & ENCODE_LEAVE_SRC)) {
393         if (s < e) {
394             Move(s,SvPVX(utf8),e-s,U8);
395             SvCUR_set(utf8,(e-s));
396         }
397         else {
398             SvCUR_set(utf8,0);
399         }
400         *SvEND(utf8) = '\0';
401     }
402
403     if (!temp_result) shrink_buffer(result);
404     if (SvTAINTED(utf8)) SvTAINTED_on(result); /* propagate taintedness */
405
406     SvSETMAGIC(utf8);
407
408     XSRETURN(1);
409 }