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
CommitLineData
9f1a4ec8 1/*
6fba102d 2
691d66bd 3Copyright 1997-2004 Gisle Aas
6fba102d
JH
4
5This library is free software; you can redistribute it and/or
6modify it under the same terms as Perl itself.
7
8
9The tables and some of the code that used to be here was borrowed from
10metamail, which comes with this message:
11
12 Copyright (c) 1991 Bell Communications Research, Inc. (Bellcore)
13
7d85a32c
JH
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",
6fba102d
JH
23 WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.
24
25*/
26
27
51ebc328 28#define PERL_NO_GET_CONTEXT /* we want efficiency */
6fba102d
JH
29#include "EXTERN.h"
30#include "perl.h"
31#include "XSUB.h"
6fba102d 32
6fba102d
JH
33#define MAX_LINE 76 /* size of encoded lines */
34
27da23d5 35static const char basis_64[] =
6fba102d
JH
36 "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";
37
38#define XX 255 /* illegal base64 char */
39#define EQ 254 /* padding */
40#define INVALID XX
41
27da23d5 42static const unsigned char index_64[256] = {
6fba102d
JH
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
6a63fb82
AMS
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
6fba102d 79
0a362e9d
RGS
80#ifndef isXDIGIT
81# define isXDIGIT isxdigit
82#endif
83
6a63fb82
AMS
84#ifndef NATIVE_TO_ASCII
85# define NATIVE_TO_ASCII(ch) (ch)
86#endif
6fba102d
JH
87
88MODULE = MIME::Base64 PACKAGE = MIME::Base64
89
90SV*
91encode_base64(sv,...)
92 SV* sv
93 PROTOTYPE: $;$
94
95 PREINIT:
96 char *str; /* string to encode */
97 SSize_t len; /* length of the string */
9f1a4ec8 98 const char*eol;/* the end-of-line sequence to use */
6fba102d
JH
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;
37fa6334 104 U32 had_utf8;
6fba102d
JH
105
106 CODE:
6a63fb82 107#if PERL_REVISION == 5 && PERL_VERSION >= 6
37fa6334
CBW
108 had_utf8 = SvUTF8(sv);
109 sv_utf8_downgrade(sv, FALSE);
6a63fb82 110#endif
6fba102d
JH
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)) {
9f1a4ec8
GA
138 const char *c = eol;
139 const char *e = eol + eollen;
6fba102d
JH
140 while (c < e)
141 *r++ = *c++;
142 chunk = 0;
143 }
144 c1 = *str++;
8be5f608 145 c2 = len > 1 ? *str++ : '\0';
6fba102d
JH
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 */
9f1a4ec8
GA
162 const char *c = eol;
163 const char *e = eol + eollen;
6fba102d
JH
164 while (c < e)
165 *r++ = *c++;
166 }
167 *r = '\0'; /* every SV in perl should be NUL-terminated */
719245bd 168#if PERL_REVISION == 5 && PERL_VERSION >= 6
37fa6334 169 if (had_utf8)
719245bd
CBW
170 sv_utf8_upgrade(sv);
171#endif
6fba102d
JH
172
173 OUTPUT:
174 RETVAL
175
176SV*
177decode_base64(sv)
178 SV* sv
179 PROTOTYPE: $
180
181 PREINIT:
182 STRLEN len;
2456140e 183 register unsigned char *str = (unsigned char*)SvPV(sv, len);
6fba102d
JH
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 {
7d85a32c 200 unsigned char uc = index_64[NATIVE_TO_ASCII(*str++)];
6fba102d
JH
201 if (uc != INVALID)
202 c[i++] = uc;
203
204 if (str == end) {
205 if (i < 4) {
6fba102d
JH
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);
7d85a32c 213
6fba102d 214 if (c[0] == EQ || c[1] == EQ) {
6fba102d
JH
215 break;
216 }
c6c619a9 217 /* printf("c0=%d,c1=%d,c2=%d,c3=%d\n", c[0],c[1],c[2],c[3]);*/
6fba102d
JH
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
6a63fb82 236
46787c0e
CBW
237int
238encoded_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 */
37fa6334 245 U32 had_utf8;
46787c0e
CBW
246
247 CODE:
248#if PERL_REVISION == 5 && PERL_VERSION >= 6
37fa6334 249 had_utf8 = SvUTF8(sv);
46787c0e
CBW
250 sv_utf8_downgrade(sv, FALSE);
251#endif
252 len = SvCUR(sv);
37fa6334
CBW
253#if PERL_REVISION == 5 && PERL_VERSION >= 6
254 if (had_utf8)
255 sv_utf8_upgrade(sv);
256#endif
46787c0e
CBW
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
272int
273decoded_base64_length(sv)
274 SV* sv
275 PROTOTYPE: $
276
277 PREINIT:
278 STRLEN len;
2456140e 279 register unsigned char *str = (unsigned char*)SvPV(sv, len);
46787c0e
CBW
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
6a63fb82
AMS
301
302MODULE = MIME::Base64 PACKAGE = MIME::QuotedPrint
303
cf0d1c66
JH
304#ifdef EBCDIC
305#define qp_isplain(c) ((c) == '\t' || ((!isprint(c) && (c) != '=')))
306#else
691d66bd 307#define qp_isplain(c) ((c) == '\t' || (((c) >= ' ' && (c) <= '~') && (c) != '='))
cf0d1c66 308#endif
6a63fb82
AMS
309
310SV*
311encode_qp(sv,...)
312 SV* sv
9e87bee3 313 PROTOTYPE: $;$$
6a63fb82
AMS
314
315 PREINIT:
9f1a4ec8 316 const char *eol;
6a63fb82 317 STRLEN eol_len;
9e87bee3 318 int binary;
6a63fb82
AMS
319 STRLEN sv_len;
320 STRLEN linelen;
321 char *beg;
322 char *end;
323 char *p;
324 char *p_beg;
325 STRLEN p_len;
37fa6334 326 U32 had_utf8;
6a63fb82
AMS
327
328 CODE:
329#if PERL_REVISION == 5 && PERL_VERSION >= 6
37fa6334
CBW
330 had_utf8 = SvUTF8(sv);
331 sv_utf8_downgrade(sv, FALSE);
6a63fb82
AMS
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
9e87bee3
RGS
341 binary = (items > 2 && SvTRUE(ST(2)));
342
6a63fb82
AMS
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 }
8be5f608 358 if (p == end || *p == '\n') {
6a63fb82
AMS
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) {
9f1a4ec8 368 while (p_len > MAX_LINE - 1 - linelen) {
6a63fb82 369 STRLEN len = MAX_LINE - 1 - linelen;
6a63fb82
AMS
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
8be5f608
RGS
384 if (p == end) {
385 break;
386 }
9e87bee3 387 else if (*p == '\n' && eol_len && !binary) {
6b10655d 388 if (linelen == 1 && SvCUR(RETVAL) > eol_len + 1 && (SvEND(RETVAL)-eol_len)[-2] == '=') {
9f1a4ec8 389 /* fixup useless soft linebreak */
6b10655d 390 (SvEND(RETVAL)-eol_len)[-2] = SvEND(RETVAL)[-1];
9f1a4ec8
GA
391 SvCUR_set(RETVAL, SvCUR(RETVAL) - 1);
392 }
393 else {
394 sv_catpvn(RETVAL, eol, eol_len);
395 }
396 p++;
6a63fb82
AMS
397 linelen = 0;
398 }
8be5f608 399 else {
6a63fb82 400 /* output escaped char (with line breaks) */
1b96abaf 401 assert(p < end);
9f1a4ec8 402 if (eol_len && linelen > MAX_LINE - 4 && !(linelen == MAX_LINE - 3 && p + 1 < end && p[1] == '\n' && !binary)) {
6a63fb82
AMS
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 }
6a63fb82
AMS
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
9e87bee3
RGS
419 if (SvCUR(RETVAL) && eol_len && linelen) {
420 sv_catpvn(RETVAL, "=", 1);
421 sv_catpvn(RETVAL, eol, eol_len);
422 }
719245bd 423#if PERL_REVISION == 5 && PERL_VERSION >= 6
37fa6334 424 if (had_utf8)
719245bd
CBW
425 sv_utf8_upgrade(sv);
426#endif
9e87bee3 427
6a63fb82
AMS
428 OUTPUT:
429 RETVAL
430
431SV*
432decode_qp(sv)
433 SV* sv
434 PROTOTYPE: $
435
436 PREINIT:
437 STRLEN len;
7235ff25 438 char *str = SvPVbyte(sv, len);
6a63fb82
AMS
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 }
ea0e37e4 467 if (*str == '=') {
691d66bd 468 if ((str + 2) < end && isXDIGIT(str[1]) && isXDIGIT(str[2])) {
ea0e37e4
GA
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 }
6a63fb82 488 }
ea0e37e4
GA
489 else {
490 *r++ = *str++;
6a63fb82 491 }
6a63fb82
AMS
492 }
493 }
2c634edc
GA
494 if (whitespace) {
495 while (whitespace < str) {
496 *r++ = *whitespace++;
497 }
498 }
6a63fb82
AMS
499 *r = '\0';
500 SvCUR_set(RETVAL, r - SvPVX(RETVAL));
501
502 OUTPUT:
503 RETVAL
504
505
506MODULE = MIME::Base64 PACKAGE = MIME::Base64