File Coverage

blib/lib/Parse/BBCode/HTML.pm

Criterion	Covered	Total	%
statement	27	27	100.0
branch	6	6	100.0
condition			n/a
subroutine	8	8	100.0
pod	3	3	100.0
total	44	44	100.0

package Parse::BBCode::HTML;
$Parse::BBCode::HTML::VERSION = '0.15';
use strict;
use warnings;
use Carp qw(croak carp);
use URI::Escape;
use base 'Exporter';
our @EXPORT_OK = qw/ &defaults &default_escapes &optional /;

my $email_valid = 0;
eval {
    require
        Email::Valid;
};
$email_valid = 1 unless $@;

my %colors = (
    aqua    => 1,
    black   => 1,
    blue    => 1,
    fuchsia => 1,
    gray    => 1,
    grey    => 1,
    green   => 1,
    lime    => 1,
    maroon  => 1,
    navy    => 1,
    olive   => 1,
    purple  => 1,
    red     => 1,
    silver  => 1,
    teal    => 1,
    white   => 1,
    yellow  => 1,
);

my %default_tags = (
    'b'     => '%s',
    'i'     => '%s',
    'u'     => '%s',
    'img'   => '',
    'url'   => 'url:%s',
    'email' => 'url:%s',
    'size'  => '%s',
    'color' => '%s',
    'list'  => {
        parse => 1,
        class => 'block',
        code => sub {
            my ($parser, $attr, $content, $attribute_fallback, $tag) = @_;
            $$content =~ s/^\n+//;
            $$content =~ s/\n+\z//;
            my $type = "ul";
            my $style = '';
            if ($attr) {
                if ($attr eq '1') {
                    $type = "ol";
                }
                elsif ($attr eq 'a') {
                    $type = "ol";
                    $style = ' style="list-style-type: lower-alpha"';
                }
            }
            return "<$type$style>$$content";
        },
    },
    '*' => {
        parse => 1,
        code => sub {
            my ($parser, $attr, $content, $attribute_fallback, $tag, $info) = @_;
            $$content =~ s/\n+\z//;
            if ($info->{stack}->[-2] eq 'list') {
                return "$$content",
            }
            return Parse::BBCode::escape_html($tag->raw_text);
        },
        close => 0,
        class => 'block',
    },
    'quote' => {
        code => sub {
            my ($parser, $attr, $content) = @_;
            my $title = 'Quote';
            if ($attr) {
                $title = Parse::BBCode::escape_html($attr);
            }
            return <<"EOM";
$title:
$$content
EOM
        },
        parse => 1,
        class => 'block',
    },
    'code'  => {
        code => sub {
            my ($parser, $attr, $content) = @_;
            my $title = 'Code';
            if ($attr) {
                $title = Parse::BBCode::escape_html($attr);
            }
            $content = Parse::BBCode::escape_html($$content);
            return <<"EOM";
$title:
$content
EOM
        },
        parse => 0,
        class => 'block',
    },
    'noparse' => '%{html}s',
);
my %optional_tags = (
    'html' => '%{noescape}s',
);

my %default_escapes = (
    html => sub {
        Parse::BBCode::escape_html($_[2]),
    },
    uri => sub {
        uri_escape($_[2]),
    },
    link => sub {
        my ($p, $tag, $var) = @_;
        if ($var =~ m{^ (?: [a-z]+:// | / ) \S+ \z}ix) {
            # allow proto:// and absolute links /
        }
        else {
            # invalid
            return;
        }
        $var = Parse::BBCode::escape_html($var);
        return $var;
    },
    email => $email_valid ? sub {
        my ($p, $tag, $var) = @_;
        # extracts the address part of the email or undef
        my $valid = Email::Valid->address($var);
        return $valid ? Parse::BBCode::escape_html($valid) : '';
    } : sub {
        my ($p, $tag, $var) = @_;
        $var = Parse::BBCode::escape_html($var);
    },
    htmlcolor => sub {
        my $color = $_[2];
        ($color =~ m/^(?:#[0-9a-fA-F]{6})\z/ || exists $colors{lc $color})
        ? $color : 'inherit'
    },
    num => sub {
        $_[2] =~ m/^[0-9]+\z/ ? $_[2] : 0;
    },
);


sub defaults {
    my ($class, @keys) = @_;
    return @keys
        ? (map { $_ => $default_tags{$_} } grep { defined $default_tags{$_} } @keys)
        : %default_tags;
}

sub default_escapes {
    my ($class, @keys) = @_;
    return @keys
        ? (map { $_ => $default_escapes{$_} } grep  { defined $default_escapes{$_} } @keys)
        : %default_escapes;
}

sub optional {
    my ($class, @keys) = @_;
    return @keys
        ? (map { $_ => $optional_tags{$_} } grep  { defined $optional_tags{$_} } @keys)
        : %optional_tags;
}



1;

__END__