libcourriel-perl 0.31-1 / usr / share / perl5 / Courriel / Helpers.pm

package Courriel::Helpers;
{
  $Courriel::Helpers::VERSION = '0.31';
}

use strict;
use warnings;

use Encode qw( decode );
use Exporter qw( import );
use List::AllUtils qw( first );

our @EXPORT_OK = qw(
    fold_header
    parse_header_with_attributes
    quote_and_escape_attribute_value
    unique_boundary
);

our $CRLF = "\x0d\x0a";

# from Email::Simple
our $LINE_SEP_RE = qr/(?:\x0a\x0d|\x0d\x0a|\x0a|\x0d)/;

sub fold_header {
    my $line = shift;

    my $folded = q{};

    # Algorithm stolen from Email::Simple::Header
    while ($line) {
        if ( $line =~ s/^(.{0,76})(\s|\z)// ) {
            $folded .= $1 . $CRLF;
            $folded .= q{  } if $line;
        }
        else {

            # Basically nothing we can do. :(
            $folded .= $line . $CRLF;
            last;
        }
    }

    return $folded;
}

sub quote_and_escape_attribute_value {
    my $val = shift;

    return $val unless $val =~ /[^a-zA-Z0-9\-]/;

    $val =~ s/(\\|")/\\$1/g;

    return qq{"$val"};
}

sub parse_header_with_attributes {
    my $text = shift;

    return unless defined $text;

    my ($val) = $text =~ /([^\s;]+)(?:\s*;\s*(.*))?\z/s;

    return (
        $val,
        _parse_attributes($2),
    );
}

our $TSPECIALS = qr{\Q()<>@,;:\"/[]?=};

my $extract_quoted = qr/
                           (?:
                               \"
                               (?<quoted_value>
                                   [^\\\"]*
                                   (?:
                                       \\.[^\\\"]*
                                   )*
                               )
                               \"
                           |
                               \'
                               (?<quoted_value>
                                   [^\\\']*
                                   (?:
                                       \\.[^\\\']*
                                   )*
                               )
                               \'
                           )
                       /x;

# This is a very loose regex. RFC 2231 has a much tighter definition of what
# can go in an attribute name, but this parser is designed to accept all the
# crap the internet throws at it.
my $attr_re = qr/
                    (?<name>[^\s=\*]+)     # names cannot include spaces, "=", or "*"
                    (?:
                        \*(?<order>[\d+])
                    )?
                    (?<is_encoded>\*)?
                    =
                    (?:
                        $extract_quoted
                    |
                        (?<value>[^\s;]+)  # unquoted values cannot contain spaces
                    )
                    (\s*;\s*)?
                /xs;

sub _parse_attributes {
    my $attr_text = shift;

    return {} unless defined $attr_text && length $attr_text;

    my $attrs = {};

    while ( $attr_text =~ /\G$attr_re/g ) {
        my $name = $+{name};

        my $value;
        my $charset;
        my $language;

        my $order = $+{order} || 0 ;

        if ( $+{is_encoded} ) {
            if ($order) {
                $value = _decode_raw_value(
                    $+{value},
                    $attrs->{$name}[$order]{charset},
                );
            }
            else {
                ( $charset, $language, my $raw ) = split /\'/, $+{value}, 3;
                $language = undef unless length $language;

                $value = _decode_raw_value( $raw, $charset );
            }
        }
        elsif ( defined $+{quoted_value} ) {
            ( $value = $+{quoted_value} ) =~ s/\G(.*?)\\(.)/$1$2/g;
        }
        else {
            $value = $+{value};
        }

        $attrs->{$name}[ $order] = {
            value    => $value,
            charset  => $charset,
            language => $language,
        };
    }

    return {
        map { $_ => _inflate_attribute( $_, $attrs->{$_} ) }
            keys %{$attrs}
    };
}

sub _decode_raw_value {
    my $raw     = shift;
    my $charset = shift;

    $raw =~ s/%([\da-fA-F]{2})/chr(hex($1))/eg;

    return $raw unless defined $charset;

    return decode( $charset, $raw );
}

sub _inflate_attribute {
    my $name     = shift;
    my $raw_data = shift;

    my $value = join q{}, grep { defined } map { $_->{value} } @{$raw_data};

    my %p = (
        name  => $_,
        value => $value,
    );

    for my $key (qw( charset language )) {
        $p{$key} = $raw_data->[0]{$key}
            if defined $raw_data->[0]{$key};
    }

    return Courriel::HeaderAttribute->new(%p);
}

sub unique_boundary {
    return Email::MessageID->new()->user();
}

# Courriel::HeaderAttribute requires that $TSPECIALS be defined
require Courriel::HeaderAttribute;

1;