[perl5.git] / cpan / MIME-Base64 / Base64.xs

/*

Copyright 1997-2004 Gisle Aas

This library is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.


The tables and some of the code that used to be here was borrowed from
metamail, which comes with this message:

  Copyright (c) 1991 Bell Communications Research, Inc. (Bellcore)

  Permission to use, copy, modify, and distribute this material
  for any purpose and without fee is hereby granted, provided
  that the above copyright notice and this permission notice
  appear in all copies, and that the name of Bellcore not be
  used in advertising or publicity pertaining to this
  material without the specific, prior written permission
  of an authorized representative of Bellcore.	BELLCORE
  MAKES NO REPRESENTATIONS ABOUT THE ACCURACY OR SUITABILITY
  OF THIS MATERIAL FOR ANY PURPOSE.  IT IS PROVIDED "AS IS",
  WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES.

*/


#ifdef __cplusplus
extern "C" {
#endif
#define PERL_NO_GET_CONTEXT     /* we want efficiency */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#ifdef __cplusplus
}
#endif

#define MAX_LINE  76 /* size of encoded lines */

static const char basis_64[] =
   "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/";

#define XX      255	/* illegal base64 char */
#define EQ      254	/* padding */
#define INVALID XX

static const unsigned char index_64[256] = {
    XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
    XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
    XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,62, XX,XX,XX,63,
    52,53,54,55, 56,57,58,59, 60,61,XX,XX, XX,EQ,XX,XX,
    XX, 0, 1, 2,  3, 4, 5, 6,  7, 8, 9,10, 11,12,13,14,
    15,16,17,18, 19,20,21,22, 23,24,25,XX, XX,XX,XX,XX,
    XX,26,27,28, 29,30,31,32, 33,34,35,36, 37,38,39,40,
    41,42,43,44, 45,46,47,48, 49,50,51,XX, XX,XX,XX,XX,

    XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
    XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
    XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
    XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
    XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
    XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
    XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
    XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX, XX,XX,XX,XX,
};

#ifdef SvPVbyte
#   if PERL_REVISION == 5 && PERL_VERSION < 7
       /* SvPVbyte does not work in perl-5.6.1, borrowed version for 5.7.3 */
#       undef SvPVbyte
#       define SvPVbyte(sv, lp) \
          ((SvFLAGS(sv) & (SVf_POK|SVf_UTF8)) == (SVf_POK) \
           ? ((lp = SvCUR(sv)), SvPVX(sv)) : my_sv_2pvbyte(aTHX_ sv, &lp))
       static char *
       my_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
       {   
           sv_utf8_downgrade(sv,0);
           return SvPV(sv,*lp);
       }
#   endif
#else
#   define SvPVbyte SvPV
#endif

#ifndef isXDIGIT
#   define isXDIGIT isxdigit
#endif

#ifndef NATIVE_TO_ASCII
#   define NATIVE_TO_ASCII(ch) (ch)
#endif

MODULE = MIME::Base64		PACKAGE = MIME::Base64

SV*
encode_base64(sv,...)
	SV* sv
	PROTOTYPE: $;$

	PREINIT:
	char *str;     /* string to encode */
	SSize_t len;   /* length of the string */
	const char*eol;/* the end-of-line sequence to use */
	STRLEN eollen; /* length of the EOL sequence */
	char *r;       /* result string */
	STRLEN rlen;   /* length of result string */
	unsigned char c1, c2, c3;
	int chunk;
	U32 had_utf8;

	CODE:
#if PERL_REVISION == 5 && PERL_VERSION >= 6
	had_utf8 = SvUTF8(sv);
	sv_utf8_downgrade(sv, FALSE);
#endif
	str = SvPV(sv, rlen); /* SvPV(sv, len) gives warning for signed len */
	len = (SSize_t)rlen;

	/* set up EOL from the second argument if present, default to "\n" */
	if (items > 1 && SvOK(ST(1))) {
	    eol = SvPV(ST(1), eollen);
	} else {
	    eol = "\n";
	    eollen = 1;
	}

	/* calculate the length of the result */
	rlen = (len+2) / 3 * 4;	 /* encoded bytes */
	if (rlen) {
	    /* add space for EOL */
	    rlen += ((rlen-1) / MAX_LINE + 1) * eollen;
	}

	/* allocate a result buffer */
	RETVAL = newSV(rlen ? rlen : 1);
	SvPOK_on(RETVAL);	
	SvCUR_set(RETVAL, rlen);
	r = SvPVX(RETVAL);

	/* encode */
	for (chunk=0; len > 0; len -= 3, chunk++) {
	    if (chunk == (MAX_LINE/4)) {
		const char *c = eol;
		const char *e = eol + eollen;
		while (c < e)
		    *r++ = *c++;
		chunk = 0;
	    }
	    c1 = *str++;
	    c2 = len > 1 ? *str++ : '\0';
	    *r++ = basis_64[c1>>2];
	    *r++ = basis_64[((c1 & 0x3)<< 4) | ((c2 & 0xF0) >> 4)];
	    if (len > 2) {
		c3 = *str++;
		*r++ = basis_64[((c2 & 0xF) << 2) | ((c3 & 0xC0) >>6)];
		*r++ = basis_64[c3 & 0x3F];
	    } else if (len == 2) {
		*r++ = basis_64[(c2 & 0xF) << 2];
		*r++ = '=';
	    } else { /* len == 1 */
		*r++ = '=';
		*r++ = '=';
	    }
	}
	if (rlen) {
	    /* append eol to the result string */
	    const char *c = eol;
	    const char *e = eol + eollen;
	    while (c < e)
		*r++ = *c++;
	}
	*r = '\0';  /* every SV in perl should be NUL-terminated */
#if PERL_REVISION == 5 && PERL_VERSION >= 6
	if (had_utf8)
	    sv_utf8_upgrade(sv);
#endif

	OUTPUT:
	RETVAL

SV*
decode_base64(sv)
	SV* sv
	PROTOTYPE: $

	PREINIT:
	STRLEN len;
	register unsigned char *str = (unsigned char*)SvPV(sv, len);
	unsigned char const* end = str + len;
	char *r;
	unsigned char c[4];

	CODE:
	{
	    /* always enough, but might be too much */
	    STRLEN rlen = len * 3 / 4;
	    RETVAL = newSV(rlen ? rlen : 1);
	}
        SvPOK_on(RETVAL);
        r = SvPVX(RETVAL);

	while (str < end) {
	    int i = 0;
            do {
		unsigned char uc = index_64[NATIVE_TO_ASCII(*str++)];
		if (uc != INVALID)
		    c[i++] = uc;

		if (str == end) {
		    if (i < 4) {
			if (i < 2) goto thats_it;
			if (i == 2) c[2] = EQ;
			c[3] = EQ;
		    }
		    break;
		}
            } while (i < 4);
	
	    if (c[0] == EQ || c[1] == EQ) {
		break;
            }
	    /* printf("c0=%d,c1=%d,c2=%d,c3=%d\n", c[0],c[1],c[2],c[3]);*/

	    *r++ = (c[0] << 2) | ((c[1] & 0x30) >> 4);

	    if (c[2] == EQ)
		break;
	    *r++ = ((c[1] & 0x0F) << 4) | ((c[2] & 0x3C) >> 2);

	    if (c[3] == EQ)
		break;
	    *r++ = ((c[2] & 0x03) << 6) | c[3];
	}

      thats_it:
	SvCUR_set(RETVAL, r - SvPVX(RETVAL));
	*r = '\0';

	OUTPUT:
	RETVAL

int
encoded_base64_length(sv,...)
	SV* sv
	PROTOTYPE: $;$

	PREINIT:
	SSize_t len;   /* length of the string */
	STRLEN eollen; /* length of the EOL sequence */
	U32 had_utf8;

	CODE:
#if PERL_REVISION == 5 && PERL_VERSION >= 6
	had_utf8 = SvUTF8(sv);
	sv_utf8_downgrade(sv, FALSE);
#endif
	len = SvCUR(sv);
#if PERL_REVISION == 5 && PERL_VERSION >= 6
	if (had_utf8)
	    sv_utf8_upgrade(sv);
#endif

	if (items > 1 && SvOK(ST(1))) {
	    eollen = SvCUR(ST(1));
	} else {
	    eollen = 1;
	}

	RETVAL = (len+2) / 3 * 4;	 /* encoded bytes */
	if (RETVAL) {
	    RETVAL += ((RETVAL-1) / MAX_LINE + 1) * eollen;
	}

	OUTPUT:
	RETVAL

int
decoded_base64_length(sv)
	SV* sv
	PROTOTYPE: $

	PREINIT:
	STRLEN len;
	register unsigned char *str = (unsigned char*)SvPV(sv, len);
	unsigned char const* end = str + len;
	int i = 0;

	CODE:
	RETVAL = 0;
	while (str < end) {
	    unsigned char uc = index_64[NATIVE_TO_ASCII(*str++)];
	    if (uc == INVALID)
		continue;
	    if (uc == EQ)
	        break;
	    if (i++) {
		RETVAL++;
		if (i == 4)
		    i = 0;
	    }
	}

	OUTPUT:
	RETVAL


MODULE = MIME::Base64		PACKAGE = MIME::QuotedPrint

#ifdef EBCDIC
#define qp_isplain(c) ((c) == '\t' || ((!isprint(c) && (c) != '=')))
#else
#define qp_isplain(c) ((c) == '\t' || (((c) >= ' ' && (c) <= '~') && (c) != '='))
#endif

SV*
encode_qp(sv,...)
	SV* sv
	PROTOTYPE: $;$$

	PREINIT:
	const char *eol;
	STRLEN eol_len;
	int binary;
	STRLEN sv_len;
	STRLEN linelen;
	char *beg;
	char *end;
	char *p;
	char *p_beg;
	STRLEN p_len;
	U32 had_utf8;

	CODE:
#if PERL_REVISION == 5 && PERL_VERSION >= 6
        had_utf8 = SvUTF8(sv);
	sv_utf8_downgrade(sv, FALSE);
#endif
	/* set up EOL from the second argument if present, default to "\n" */
	if (items > 1 && SvOK(ST(1))) {
	    eol = SvPV(ST(1), eol_len);
	} else {
	    eol = "\n";
	    eol_len = 1;
	}

	binary = (items > 2 && SvTRUE(ST(2)));

	beg = SvPV(sv, sv_len);
	end = beg + sv_len;

	RETVAL = newSV(sv_len + 1);
	sv_setpv(RETVAL, "");
	linelen = 0;

	p = beg;
	while (1) {
	    p_beg = p;

	    /* skip past as much plain text as possible */
	    while (p < end && qp_isplain(*p)) {
	        p++;
	    }
	    if (p == end || *p == '\n') {
		/* whitespace at end of line must be encoded */
		while (p > p_beg && (*(p - 1) == '\t' || *(p - 1) == ' '))
		    p--;
	    }

	    p_len = p - p_beg;
	    if (p_len) {
	        /* output plain text (with line breaks) */
	        if (eol_len) {
		    while (p_len > MAX_LINE - 1 - linelen) {
			STRLEN len = MAX_LINE - 1 - linelen;
			sv_catpvn(RETVAL, p_beg, len);
			p_beg += len;
			p_len -= len;
			sv_catpvn(RETVAL, "=", 1);
			sv_catpvn(RETVAL, eol, eol_len);
		        linelen = 0;
		    }
                }
		if (p_len) {
	            sv_catpvn(RETVAL, p_beg, p_len);
	            linelen += p_len;
		}
	    }

	    if (p == end) {
		break;
            }
	    else if (*p == '\n' && eol_len && !binary) {
		if (linelen == 1 && SvCUR(RETVAL) > eol_len + 1 && SvEND(RETVAL)[-eol_len - 2] == '=') {
		    /* fixup useless soft linebreak */
		    SvEND(RETVAL)[-eol_len - 2] = SvEND(RETVAL)[-1];
		    SvCUR_set(RETVAL, SvCUR(RETVAL) - 1);
		}
		else {
		    sv_catpvn(RETVAL, eol, eol_len);
		}
		p++;
		linelen = 0;
	    }
	    else {
		/* output escaped char (with line breaks) */
	        assert(p < end);
		if (eol_len && linelen > MAX_LINE - 4 && !(linelen == MAX_LINE - 3 && p + 1 < end && p[1] == '\n' && !binary)) {
		    sv_catpvn(RETVAL, "=", 1);
		    sv_catpvn(RETVAL, eol, eol_len);
		    linelen = 0;
		}
	        sv_catpvf(RETVAL, "=%02X", (unsigned char)*p);
	        p++;
	        linelen += 3;
	    }

	    /* optimize reallocs a bit */
	    if (SvLEN(RETVAL) > 80 && SvLEN(RETVAL) - SvCUR(RETVAL) < 3) {
		STRLEN expected_len = (SvCUR(RETVAL) * sv_len) / (p - beg);
     		SvGROW(RETVAL, expected_len);
	    }
        }

	if (SvCUR(RETVAL) && eol_len && linelen) {
	    sv_catpvn(RETVAL, "=", 1);
	    sv_catpvn(RETVAL, eol, eol_len);
	}
#if PERL_REVISION == 5 && PERL_VERSION >= 6
	if (had_utf8)
	    sv_utf8_upgrade(sv);
#endif

	OUTPUT:
	RETVAL

SV*
decode_qp(sv)
	SV* sv
	PROTOTYPE: $

        PREINIT:
	STRLEN len;
	char *str = SvPVbyte(sv, len);
	char const* end = str + len;
	char *r;
	char *whitespace = 0;

        CODE:
	RETVAL = newSV(len ? len : 1);
        SvPOK_on(RETVAL);
        r = SvPVX(RETVAL);
	while (str < end) {
	    if (*str == ' ' || *str == '\t') {
		if (!whitespace)
		    whitespace = str;
		str++;
	    }
	    else if (*str == '\r' && (str + 1) < end && str[1] == '\n') {
		str++;
	    }
	    else if (*str == '\n') {
		whitespace = 0;
		*r++ = *str++;
	    }
	    else {
		if (whitespace) {
		    while (whitespace < str) {
			*r++ = *whitespace++;
		    }
		    whitespace = 0;
                }
            	if (*str == '=') {
		    if ((str + 2) < end && isXDIGIT(str[1]) && isXDIGIT(str[2])) {
	                char buf[3];
                        str++;
	                buf[0] = *str++;
		        buf[1] = *str++;
	                buf[2] = '\0';
		        *r++ = (char)strtol(buf, 0, 16);
	            }
		    else {
		        /* look for soft line break */
		        char *p = str + 1;
		        while (p < end && (*p == ' ' || *p == '\t'))
		            p++;
		        if (p < end && *p == '\n')
		     	    str = p + 1;
		        else if ((p + 1) < end && *p == '\r' && *(p + 1) == '\n')
		            str = p + 2;
		        else
		            *r++ = *str++; /* give up */
		    }
		}
		else {
		    *r++ = *str++;
		}
	    }
	}
	if (whitespace) {
	    while (whitespace < str) {
		*r++ = *whitespace++;
	    }
        }
	*r = '\0';
	SvCUR_set(RETVAL, r - SvPVX(RETVAL));

        OUTPUT:
	RETVAL


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