This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
POSIX: Prefer system's NAN/INFINITY for POSIX::NAN and POSIX::INFINITY.
[perl5.git] / cpan / MIME-Base64 / Base64.xs
1 /*
2
3 Copyright 1997-2004 Gisle Aas
4
5 This library is free software; you can redistribute it and/or
6 modify it under the same terms as Perl itself.
7
8
9 The tables and some of the code that used to be here was borrowed from
10 metamail, which comes with this message:
11
12   Copyright (c) 1991 Bell Communications Research, Inc. (Bellcore)
13
14   Permission to use, copy, modify, and distribute this material
15   for any purpose and without fee is hereby granted, provided
16   that the above copyright notice and this permission notice
17   appear in all copies, and that the name of Bellcore not be
18   used in advertising or publicity pertaining to this
19   material without the specific, prior written permission
20   of an authorized representative of Bellcore.  BELLCORE
21   MAKES NO REPRESENTATIONS ABOUT THE ACCURACY OR SUITABILITY
22   OF THIS MATERIAL FOR ANY PURPOSE.  IT IS PROVIDED "AS IS",
23   WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
24
25 */
26
27
28 #define PERL_NO_GET_CONTEXT     /* we want efficiency */
29 #include "EXTERN.h"
30 #include "perl.h"
31 #include "XSUB.h"
32
33 #define MAX_LINE  76 /* size of encoded lines */
34
35 static const char basis_64[] =
36    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";
37
38 #define XX      255     /* illegal base64 char */
39 #define EQ      254     /* padding */
40 #define INVALID XX
41
42 static const unsigned char index_64[256] = {
43     XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
44     XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
45     XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,62, XX,XX,XX,63,
46     52,53,54,55, 56,57,58,59, 60,61,XX,XX, XX,EQ,XX,XX,
47     XX, 0, 1, 2,  3, 4, 5, 6,  7, 8, 9,10, 11,12,13,14,
48     15,16,17,18, 19,20,21,22, 23,24,25,XX, XX,XX,XX,XX,
49     XX,26,27,28, 29,30,31,32, 33,34,35,36, 37,38,39,40,
50     41,42,43,44, 45,46,47,48, 49,50,51,XX, XX,XX,XX,XX,
51
52     XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
53     XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
54     XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
55     XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
56     XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
57     XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
58     XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
59     XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
60 };
61
62 #ifdef SvPVbyte
63 #   if PERL_REVISION == 5 && PERL_VERSION < 7
64        /* SvPVbyte does not work in perl-5.6.1, borrowed version for 5.7.3 */
65 #       undef SvPVbyte
66 #       define SvPVbyte(sv, lp) \
67           ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
68            ? ((lp = SvCUR(sv)), SvPVX(sv)) : my_sv_2pvbyte(aTHX_ sv, &lp))
69        static char *
70        my_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
71        {   
72            sv_utf8_downgrade(sv,0);
73            return SvPV(sv,*lp);
74        }
75 #   endif
76 #else
77 #   define SvPVbyte SvPV
78 #endif
79
80 #ifndef isXDIGIT
81 #   define isXDIGIT isxdigit
82 #endif
83
84 #ifndef NATIVE_TO_ASCII
85 #   define NATIVE_TO_ASCII(ch) (ch)
86 #endif
87
88 MODULE = MIME::Base64           PACKAGE = MIME::Base64
89
90 SV*
91 encode_base64(sv,...)
92         SV* sv
93         PROTOTYPE: $;$
94
95         PREINIT:
96         char *str;     /* string to encode */
97         SSize_t len;   /* length of the string */
98         const char*eol;/* the end-of-line sequence to use */
99         STRLEN eollen; /* length of the EOL sequence */
100         char *r;       /* result string */
101         STRLEN rlen;   /* length of result string */
102         unsigned char c1, c2, c3;
103         int chunk;
104         U32 had_utf8;
105
106         CODE:
107 #if PERL_REVISION == 5 && PERL_VERSION >= 6
108         had_utf8 = SvUTF8(sv);
109         sv_utf8_downgrade(sv, FALSE);
110 #endif
111         str = SvPV(sv, rlen); /* SvPV(sv, len) gives warning for signed len */
112         len = (SSize_t)rlen;
113
114         /* set up EOL from the second argument if present, default to "\n" */
115         if (items > 1 && SvOK(ST(1))) {
116             eol = SvPV(ST(1), eollen);
117         } else {
118             eol = "\n";
119             eollen = 1;
120         }
121
122         /* calculate the length of the result */
123         rlen = (len+2) / 3 * 4;  /* encoded bytes */
124         if (rlen) {
125             /* add space for EOL */
126             rlen += ((rlen-1) / MAX_LINE + 1) * eollen;
127         }
128
129         /* allocate a result buffer */
130         RETVAL = newSV(rlen ? rlen : 1);
131         SvPOK_on(RETVAL);       
132         SvCUR_set(RETVAL, rlen);
133         r = SvPVX(RETVAL);
134
135         /* encode */
136         for (chunk=0; len > 0; len -= 3, chunk++) {
137             if (chunk == (MAX_LINE/4)) {
138                 const char *c = eol;
139                 const char *e = eol + eollen;
140                 while (c < e)
141                     *r++ = *c++;
142                 chunk = 0;
143             }
144             c1 = *str++;
145             c2 = len > 1 ? *str++ : '\0';
146             *r++ = basis_64[c1>>2];
147             *r++ = basis_64[((c1 & 0x3)<< 4) | ((c2 & 0xF0) >> 4)];
148             if (len > 2) {
149                 c3 = *str++;
150                 *r++ = basis_64[((c2 & 0xF) << 2) | ((c3 & 0xC0) >>6)];
151                 *r++ = basis_64[c3 & 0x3F];
152             } else if (len == 2) {
153                 *r++ = basis_64[(c2 & 0xF) << 2];
154                 *r++ = '=';
155             } else { /* len == 1 */
156                 *r++ = '=';
157                 *r++ = '=';
158             }
159         }
160         if (rlen) {
161             /* append eol to the result string */
162             const char *c = eol;
163             const char *e = eol + eollen;
164             while (c < e)
165                 *r++ = *c++;
166         }
167         *r = '\0';  /* every SV in perl should be NUL-terminated */
168 #if PERL_REVISION == 5 && PERL_VERSION >= 6
169         if (had_utf8)
170             sv_utf8_upgrade(sv);
171 #endif
172
173         OUTPUT:
174         RETVAL
175
176 SV*
177 decode_base64(sv)
178         SV* sv
179         PROTOTYPE: $
180
181         PREINIT:
182         STRLEN len;
183         register unsigned char *str = (unsigned char*)SvPV(sv, len);
184         unsigned char const* end = str + len;
185         char *r;
186         unsigned char c[4];
187
188         CODE:
189         {
190             /* always enough, but might be too much */
191             STRLEN rlen = len * 3 / 4;
192             RETVAL = newSV(rlen ? rlen : 1);
193         }
194         SvPOK_on(RETVAL);
195         r = SvPVX(RETVAL);
196
197         while (str < end) {
198             int i = 0;
199             do {
200                 unsigned char uc = index_64[NATIVE_TO_ASCII(*str++)];
201                 if (uc != INVALID)
202                     c[i++] = uc;
203
204                 if (str == end) {
205                     if (i < 4) {
206                         if (i < 2) goto thats_it;
207                         if (i == 2) c[2] = EQ;
208                         c[3] = EQ;
209                     }
210                     break;
211                 }
212             } while (i < 4);
213         
214             if (c[0] == EQ || c[1] == EQ) {
215                 break;
216             }
217             /* printf("c0=%d,c1=%d,c2=%d,c3=%d\n", c[0],c[1],c[2],c[3]);*/
218
219             *r++ = (c[0] << 2) | ((c[1] & 0x30) >> 4);
220
221             if (c[2] == EQ)
222                 break;
223             *r++ = ((c[1] & 0x0F) << 4) | ((c[2] & 0x3C) >> 2);
224
225             if (c[3] == EQ)
226                 break;
227             *r++ = ((c[2] & 0x03) << 6) | c[3];
228         }
229
230       thats_it:
231         SvCUR_set(RETVAL, r - SvPVX(RETVAL));
232         *r = '\0';
233
234         OUTPUT:
235         RETVAL
236
237 int
238 encoded_base64_length(sv,...)
239         SV* sv
240         PROTOTYPE: $;$
241
242         PREINIT:
243         SSize_t len;   /* length of the string */
244         STRLEN eollen; /* length of the EOL sequence */
245         U32 had_utf8;
246
247         CODE:
248 #if PERL_REVISION == 5 && PERL_VERSION >= 6
249         had_utf8 = SvUTF8(sv);
250         sv_utf8_downgrade(sv, FALSE);
251 #endif
252         len = SvCUR(sv);
253 #if PERL_REVISION == 5 && PERL_VERSION >= 6
254         if (had_utf8)
255             sv_utf8_upgrade(sv);
256 #endif
257
258         if (items > 1 && SvOK(ST(1))) {
259             eollen = SvCUR(ST(1));
260         } else {
261             eollen = 1;
262         }
263
264         RETVAL = (len+2) / 3 * 4;        /* encoded bytes */
265         if (RETVAL) {
266             RETVAL += ((RETVAL-1) / MAX_LINE + 1) * eollen;
267         }
268
269         OUTPUT:
270         RETVAL
271
272 int
273 decoded_base64_length(sv)
274         SV* sv
275         PROTOTYPE: $
276
277         PREINIT:
278         STRLEN len;
279         register unsigned char *str = (unsigned char*)SvPV(sv, len);
280         unsigned char const* end = str + len;
281         int i = 0;
282
283         CODE:
284         RETVAL = 0;
285         while (str < end) {
286             unsigned char uc = index_64[NATIVE_TO_ASCII(*str++)];
287             if (uc == INVALID)
288                 continue;
289             if (uc == EQ)
290                 break;
291             if (i++) {
292                 RETVAL++;
293                 if (i == 4)
294                     i = 0;
295             }
296         }
297
298         OUTPUT:
299         RETVAL
300
301
302 MODULE = MIME::Base64           PACKAGE = MIME::QuotedPrint
303
304 #ifdef EBCDIC
305 #define qp_isplain(c) ((c) == '\t' || ((!isprint(c) && (c) != '=')))
306 #else
307 #define qp_isplain(c) ((c) == '\t' || (((c) >= ' ' && (c) <= '~') && (c) != '='))
308 #endif
309
310 SV*
311 encode_qp(sv,...)
312         SV* sv
313         PROTOTYPE: $;$$
314
315         PREINIT:
316         const char *eol;
317         STRLEN eol_len;
318         int binary;
319         STRLEN sv_len;
320         STRLEN linelen;
321         char *beg;
322         char *end;
323         char *p;
324         char *p_beg;
325         STRLEN p_len;
326         U32 had_utf8;
327
328         CODE:
329 #if PERL_REVISION == 5 && PERL_VERSION >= 6
330         had_utf8 = SvUTF8(sv);
331         sv_utf8_downgrade(sv, FALSE);
332 #endif
333         /* set up EOL from the second argument if present, default to "\n" */
334         if (items > 1 && SvOK(ST(1))) {
335             eol = SvPV(ST(1), eol_len);
336         } else {
337             eol = "\n";
338             eol_len = 1;
339         }
340
341         binary = (items > 2 && SvTRUE(ST(2)));
342
343         beg = SvPV(sv, sv_len);
344         end = beg + sv_len;
345
346         RETVAL = newSV(sv_len + 1);
347         sv_setpv(RETVAL, "");
348         linelen = 0;
349
350         p = beg;
351         while (1) {
352             p_beg = p;
353
354             /* skip past as much plain text as possible */
355             while (p < end && qp_isplain(*p)) {
356                 p++;
357             }
358             if (p == end || *p == '\n') {
359                 /* whitespace at end of line must be encoded */
360                 while (p > p_beg && (*(p - 1) == '\t' || *(p - 1) == ' '))
361                     p--;
362             }
363
364             p_len = p - p_beg;
365             if (p_len) {
366                 /* output plain text (with line breaks) */
367                 if (eol_len) {
368                     while (p_len > MAX_LINE - 1 - linelen) {
369                         STRLEN len = MAX_LINE - 1 - linelen;
370                         sv_catpvn(RETVAL, p_beg, len);
371                         p_beg += len;
372                         p_len -= len;
373                         sv_catpvn(RETVAL, "=", 1);
374                         sv_catpvn(RETVAL, eol, eol_len);
375                         linelen = 0;
376                     }
377                 }
378                 if (p_len) {
379                     sv_catpvn(RETVAL, p_beg, p_len);
380                     linelen += p_len;
381                 }
382             }
383
384             if (p == end) {
385                 break;
386             }
387             else if (*p == '\n' && eol_len && !binary) {
388                 if (linelen == 1 && SvCUR(RETVAL) > eol_len + 1 && (SvEND(RETVAL)-eol_len)[-2] == '=') {
389                     /* fixup useless soft linebreak */
390                     (SvEND(RETVAL)-eol_len)[-2] = SvEND(RETVAL)[-1];
391                     SvCUR_set(RETVAL, SvCUR(RETVAL) - 1);
392                 }
393                 else {
394                     sv_catpvn(RETVAL, eol, eol_len);
395                 }
396                 p++;
397                 linelen = 0;
398             }
399             else {
400                 /* output escaped char (with line breaks) */
401                 assert(p < end);
402                 if (eol_len && linelen > MAX_LINE - 4 && !(linelen == MAX_LINE - 3 && p + 1 < end && p[1] == '\n' && !binary)) {
403                     sv_catpvn(RETVAL, "=", 1);
404                     sv_catpvn(RETVAL, eol, eol_len);
405                     linelen = 0;
406                 }
407                 sv_catpvf(RETVAL, "=%02X", (unsigned char)*p);
408                 p++;
409                 linelen += 3;
410             }
411
412             /* optimize reallocs a bit */
413             if (SvLEN(RETVAL) > 80 && SvLEN(RETVAL) - SvCUR(RETVAL) < 3) {
414                 STRLEN expected_len = (SvCUR(RETVAL) * sv_len) / (p - beg);
415                 SvGROW(RETVAL, expected_len);
416             }
417         }
418
419         if (SvCUR(RETVAL) && eol_len && linelen) {
420             sv_catpvn(RETVAL, "=", 1);
421             sv_catpvn(RETVAL, eol, eol_len);
422         }
423 #if PERL_REVISION == 5 && PERL_VERSION >= 6
424         if (had_utf8)
425             sv_utf8_upgrade(sv);
426 #endif
427
428         OUTPUT:
429         RETVAL
430
431 SV*
432 decode_qp(sv)
433         SV* sv
434         PROTOTYPE: $
435
436         PREINIT:
437         STRLEN len;
438         char *str = SvPVbyte(sv, len);
439         char const* end = str + len;
440         char *r;
441         char *whitespace = 0;
442
443         CODE:
444         RETVAL = newSV(len ? len : 1);
445         SvPOK_on(RETVAL);
446         r = SvPVX(RETVAL);
447         while (str < end) {
448             if (*str == ' ' || *str == '\t') {
449                 if (!whitespace)
450                     whitespace = str;
451                 str++;
452             }
453             else if (*str == '\r' && (str + 1) < end && str[1] == '\n') {
454                 str++;
455             }
456             else if (*str == '\n') {
457                 whitespace = 0;
458                 *r++ = *str++;
459             }
460             else {
461                 if (whitespace) {
462                     while (whitespace < str) {
463                         *r++ = *whitespace++;
464                     }
465                     whitespace = 0;
466                 }
467                 if (*str == '=') {
468                     if ((str + 2) < end && isXDIGIT(str[1]) && isXDIGIT(str[2])) {
469                         char buf[3];
470                         str++;
471                         buf[0] = *str++;
472                         buf[1] = *str++;
473                         buf[2] = '\0';
474                         *r++ = (char)strtol(buf, 0, 16);
475                     }
476                     else {
477                         /* look for soft line break */
478                         char *p = str + 1;
479                         while (p < end && (*p == ' ' || *p == '\t'))
480                             p++;
481                         if (p < end && *p == '\n')
482                             str = p + 1;
483                         else if ((p + 1) < end && *p == '\r' && *(p + 1) == '\n')
484                             str = p + 2;
485                         else
486                             *r++ = *str++; /* give up */
487                     }
488                 }
489                 else {
490                     *r++ = *str++;
491                 }
492             }
493         }
494         if (whitespace) {
495             while (whitespace < str) {
496                 *r++ = *whitespace++;
497             }
498         }
499         *r = '\0';
500         SvCUR_set(RETVAL, r - SvPVX(RETVAL));
501
502         OUTPUT:
503         RETVAL
504
505
506 MODULE = MIME::Base64           PACKAGE = MIME::Base64