[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.

*/


#define PERL_NO_GET_CONTEXT     /* we want efficiency */
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#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
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 */
6fba102d JH	34
27da23d5	35	static 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	42	static 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
	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 */
9f1a4ec8	98	const chareol;/ 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
6fba102d JH	106	CODE:
6a63fb82	107	#if PERL_REVISION == 5 && PERL_VERSION >= 6
37fa6334 CBW	108	had_utf8 = SvUTF8(sv);
37fa6334 CBW	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;
9f1a4ec8 GA	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;
9f1a4ec8 GA	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);
719245bd CBW	171	#endif
6fba102d JH	172
	173	OUTPUT:
	174	RETVAL
	175
	176	SV*
	177	decode_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;
6fba102d JH	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	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 */
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
	272	int
	273	decoded_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
	302	MODULE = 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
	310	SV*
	311	encode_qp(sv,...)
	312	SV* sv
9e87bee3	313	PROTOTYPE: $;$$
6a63fb82 AMS	314
6a63fb82 AMS	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);
37fa6334 CBW	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)));
9e87bee3 RGS	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;
6a63fb82 AMS	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);
719245bd CBW	426	#endif
9e87bee3	427
6a63fb82 AMS	428	OUTPUT:
	429	RETVAL
	430
	431	SV*
	432	decode_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 {
ea0e37e4 GA	490	r++ = str++;
6a63fb82	491	}
6a63fb82 AMS	492	}
6a63fb82 AMS	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
	506	MODULE = MIME::Base64 PACKAGE = MIME::Base64