File Coverage

blib/lib/Parse/BBCode.pm

Criterion	Covered	Total	%
statement	506	509	99.4
branch	195	210	92.8
condition	102	125	81.6
subroutine	31	31	100.0
pod	10	10	100.0
total	844	885	95.3

package Parse::BBCode;
$Parse::BBCode::VERSION = '0.15';
use strict;
use warnings;
use Parse::BBCode::Tag;
use Parse::BBCode::HTML qw/ &defaults &default_escapes &optional /;
use base 'Class::Accessor::Fast';
__PACKAGE__->follow_best_practice;
__PACKAGE__->mk_accessors(qw/
    tags allowed compiled plain strict_attributes close_open_tags error
    tree escapes direct_attribute params url_finder text_processor linebreaks
    smileys attribute_parser strip_linebreaks attribute_quote /);
#use Data::Dumper;
use Carp;
my $scalar_util = eval "require Scalar::Util; 1";

my %defaults = (
    strict_attributes   => 1,
    direct_attribute    => 1,
    linebreaks          => 1,
    smileys             => 0,
    url_finder          => 0,
    strip_linebreaks    => 1,
    attribute_quote     => '"',
);
sub new {
    my ($class, $args) = @_;
    $args ||= {};
    my %args = %$args;
    unless ($args{tags}) {
        $args{tags} = { $class->defaults };
    }
    else {
        $args{tags} = { %{ $args{tags} } };
    }
    unless ($args{escapes}) {
        $args{escapes} = {$class->default_escapes };
    }
    else {
        $args{escapes} = { %{ $args{escapes} } }
    }
    my $self = $class->SUPER::new({
        %defaults,
        %args
    });
    $self->set_allowed([ grep { length } keys %{ $self->get_tags } ]);
    $self->_compile_tags;
    return $self;
}

my $re_split = qr{ % (?:\{ (?:[a-zA-Z\|]+) \})? (?:attr|[Aas]) }x;
my $re_cmp = qr{ % (?:\{ ([a-zA-Z\|]+) \})? (attr|[Aas]) }x;

sub forbid {
    my ($self, @tags) = @_;
    my $allowed = $self->get_allowed;
    my $re = join '|', map { quotemeta } @tags;
    @$allowed = grep { ! m/^(?:$re)\z/ } @$allowed;
}

sub permit {
    my ($self, @tags) = @_;
    my $allowed = $self->get_allowed;
    my %seen;
    @$allowed = grep {
        !$seen{$_}++ && $self->get_tags->{$_};
    } (@$allowed, @tags);
}

sub _compile_tags {
    my ($self) = @_;
#    unless ($self->get_compiled) {
    {
        my $defs = $self->get_tags;

        # get definition for how text should be rendered which is not in tags
        my $plain;
        if (exists $defs->{""}) {
            $plain = delete $defs->{""};
            if (ref $plain eq 'CODE') {
                $self->set_plain($plain);
            }
        }
        else {
            my $url_finder = $self->get_url_finder;
            my $linebreaks = $self->get_linebreaks;
            my $smileys = $self->get_smileys;
            if ($url_finder) {
                my $result = eval { require URI::Find; 1 };
                unless ($result) {
                    undef $url_finder;
                }
            }
            my $escape = \&Parse::BBCode::escape_html;
            my $post_processor_1 = $escape;
            my $post_processor;
            my $text_processor = $self->get_text_processor;
            if ($text_processor) {
                $post_processor_1 = $text_processor;
            }
            if ($smileys and ref($smileys->{icons}) eq 'HASH') {
                $smileys = {
                    icons => $smileys->{icons},
                    base_url => $smileys->{base_url} || '/smileys/',
                    format => $smileys->{format} || '',
                };
                my $re = join '|', map { quotemeta $_ } sort { length $b <=> length $a }
                    keys %{ $smileys->{icons} };
                my $code = sub {
                    my ($text, $post_processor) = @_;
                    my $out = '';
                    while ($text =~ s/\A (^|.*?[\s]) ($re) (?=[\s]|$)//xsm) {
                        my ($pre, $emo) = ($1, $2);
                        my $url = "$smileys->{base_url}$smileys->{icons}->{$emo}";
                        my $emo_escaped = Parse::BBCode::escape_html($emo);
                        my $image_tag = sprintf $smileys->{format}, $url, $emo_escaped;
                        $out .= $post_processor_1->($pre) . $image_tag;
                    }
                    $out .= $post_processor_1->($text);
                    return $out;
                };
                $post_processor = $code;
            }
            else {
                $post_processor = $post_processor_1;
            }

            if ($url_finder) {
                my $url_find_sub;
                if (ref($url_finder) eq 'CODE') {
                    $url_find_sub = $url_finder;
                }
                else {
                    unless (ref($url_finder) eq 'HASH') {
                        $url_finder = {
                            max_length => 50,
                            format => '%s',
                        };
                    }
                    my $max_url = $url_finder->{max_length} || 0;
                    my $format = $url_finder->{format};
                    my $finder = URI::Find->new(sub {
                        my ($url) = @_;
                        my $title = $url;
                        if ($max_url and length($title) > $max_url) {
                            $title = substr($title, 0, $max_url) . "...";
                        }
                        my $escaped = Parse::BBCode::escape_html($url);
                        my $escaped_title = Parse::BBCode::escape_html($title);
                        my $href = sprintf $format, $escaped, $title;
                        return $href;
                    });
                    $url_find_sub = sub {
                        my ($ref_content, $post, $info) = @_;
                        $finder->find($ref_content, sub { $post->($_[0], $info) });
                    };
                }
                $plain = sub {
                    my ($parser, $attr, $content, $info) = @_;
                    unless ($info->{classes}->{url}) {
                        $url_find_sub->(\$content, $post_processor, $info);
                    }
                    else {
                        $content = $post_processor->($content);
                    }
                    $content =~ s/\r?\n|\r/\n/g if $linebreaks;
                    $content;
                };
            }
            else {
                $plain = sub {
                    my ($parser, $attr, $content, $info) = @_;
                    my $text = $post_processor->($content, $info);
                    $text =~ s/\r?\n|\r/\n/g if $linebreaks;
                    $text;
                };
            }
            $self->set_plain($plain);
        }

        # now compile the rest of definitions
        for my $key (keys %$defs) {
            my $def = $defs->{$key};
            #warn __PACKAGE__.':'.__LINE__.": $key: $def\n";
            if (not ref $def) {
                my $new_def = $self->_compile_def($def);
                $defs->{$key} = $new_def;
            }
            elsif (not exists $def->{code} and exists $def->{output}) {
                my $new_def = $self->_compile_def($def);
                $defs->{$key} = $new_def;
            }
            $defs->{$key}->{class} ||= 'inline';
            $defs->{$key}->{classic} = 1 unless defined $defs->{$key}->{classic};
            $defs->{$key}->{close} = 1 unless defined $defs->{$key}->{close};
        }
        $self->set_compiled(1);
    }
}

sub _compile_def {
    my ($self, $def) = @_;
    my $esc = $self->get_escapes;
    my $parse = 0;
    my $new_def = {};
    my $output = $def;
    my $close = 1;
    my $class = 'inline';
    if (ref $def eq 'HASH') {
        $new_def = { %$def };
        $output = delete $new_def->{output};
        $parse = $new_def->{parse};
        $close = $new_def->{close} if exists $new_def->{close};
        $class = $new_def->{class} if exists $new_def->{class};
    }
    else {
    }
    # we have a string, compile
    #warn __PACKAGE__.':'.__LINE__.": $key => $output\n";
    if ($output =~ s/^(inline|block|url)://) {
        $class = $1;
    }
    my @parts = split m!($re_split)!, $output;
    #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@parts], ['parts']);
    my @compiled;
    for my $p (@parts) {
        if ($p =~ m/$re_cmp/) {
            my ($escape, $type) = ($1, $2);
            $escape ||= 'parse';
            my @escapes = split /\|/, $escape;
            if (grep { $_ eq 'parse' } @escapes) {
                $parse = 1;
            }
            push @compiled, [\@escapes, $type];
        }
        else {
            push @compiled, $p;
        }
        #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@compiled], ['compiled']);
    }
    my $code = sub {
        my ($self, $attr, $string, $fallback, $tag) = @_;
        my $out = '';
        for my $c (@compiled) {

            # just text
            unless (ref $c) {
                $out .= $c;
            }
            # tag attribute or content
            else {
                my ($escapes, $type) = @$c;
                my @escapes = @$escapes;
                my $var = '';
                my $attributes = $tag->get_attr;
                if ($type eq 'attr' and @$attributes > 1) {
                    my $name = shift @escapes;
                    for my $item (@$attributes[1 .. $#$attributes]) {
                        if ($item->[0] eq $name) {
                            $var = $item->[1];
                            last;
                        }
                    }
                }
                elsif ($type eq 'a') {
                    $var = $attr;
                }
                elsif ($type eq 'A') {
                    $var = $fallback;
                }
                elsif ($type eq 's') {
                    if (ref $string eq 'SCALAR') {
                        # this text is already finished and escaped
                        $string = $$string;
                    }
                    $var = $string;
                }
                for my $e (@escapes) {
                    my $sub = $esc->{$e};
                    if ($sub) {
                        $var = $sub->($self, $c, $var);
                        unless (defined $var) {
                            # if escape returns undef, we return it unparsed
                            return $tag->get_start
                                . (join '', map {
                                    $self->_render_tree($_);
                                } @{ $tag->get_content })
                                . $tag->get_end;
                        }
                    }
                }
                $out .= $var;
            }
        }
        return $out;
    };
    $new_def->{parse} = $parse;
    $new_def->{code} = $code;
    $new_def->{close} = $close;
    $new_def->{class} = $class;
    return $new_def;
}

sub _render_text {
    my ($self, $tag, $text, $info) = @_;
    #warn __PACKAGE__.':'.__LINE__.": text '$text'\n";
    defined (my $code = $self->get_plain) or return $text;
    return $code->($self, $tag, $text, $info);
}

sub parse {
    my ($self, $text, $params) = @_;
    my $parse_attributes = $self->get_attribute_parser ? $self->get_attribute_parser : $self->can('parse_attributes');
    $self->set_error(undef);
    my $defs = $self->get_tags;
    my $tags = $self->get_allowed || [keys %$defs];
    my @classic_tags = grep { $defs->{$_}->{classic} } @$tags;
    my @short_tags = grep { $defs->{$_}->{short} } @$tags;
    my $re_classic = join '|', map { quotemeta } sort {length $b <=> length $a } @classic_tags;
    #$re_classic = qr/$re_classic/i;
    my $re_short = join '|', map { quotemeta } sort {length $b <=> length $a } @short_tags;
    #$re_short = qr/$re_short/i;
    #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$re], ['re']);
    my @tags;
    my $out = '';
    my @opened;
    my $current_open_re = '';
    my $callback_found_text = sub {
        my ($text) = @_;
        if (@opened) {
            my $o = $opened[-1];
            $o->add_content($text);
        }
        else {
            if (@tags and !ref $tags[-1]) {
                # text tag, concatenate
                $tags[-1] .= $text;
            }
            else {
                push @tags, $text;
            }
        }
        #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@opened], ['opened']);
    };
    my $callback_found_tag;
    my $in_url = 0;
    $callback_found_tag = sub {
        my ($tag) = @_;
        #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$tag], ['tag']);
        #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@opened], ['opened']);
        if (@opened) {
            my $o = $opened[-1];
            my $class = $o->get_class;
            #warn __PACKAGE__.':'.__LINE__.": tag $tag\n";
            if (ref $tag and $class =~ m/inline|url/ and $tag->get_class eq 'block') {
                $self->_add_error('block_inline', $tag);
                pop @opened;
                #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$o], ['o']);
                if ($self->get_close_open_tags) {
                    # we close the tag for you
                    $self->_finish_tag($o, '[/' . $o->get_name . ']', 1);
                    $callback_found_tag->($o);
                    $callback_found_tag->($tag);
                }
                else {
                    # nope, no automatic closing, invalidate all
                    # open inline tags before
                    my @red = $o->_reduce;
                    $callback_found_tag->($_) for @red;
                    $callback_found_tag->($tag);
                }
            }
            elsif (ref $tag) {
                my $def = $defs->{lc $tag->get_name};
                my $parse = $def->{parse};
                if ($parse) {
                    $o->add_content($tag);
                }
                else {
                    my $content = $tag->get_content;
                    my $string = '';
                    for my $c (@$content) {
                        if (ref $c) {
                            $string .= $c->raw_text( auto_close => 0 );
                        }
                        else {
                            $string .= $c;
                        }
                    }
                    $tag->set_content([$string]);
                    $o->add_content($tag);
                }
            }
            else {
                $o->add_content($tag);
            }
        }
        elsif (ref $tag) {
            my $def = $defs->{lc $tag->get_name};
            my $parse = $def->{parse};
            if ($parse) {
                push @tags, $tag;
            }
            else {
                my $content = $tag->get_content;
                my $string = '';
                for my $c (@$content) {
                    if (ref $c) {
                        $string .= $c->raw_text( auto_close => 0 );
                    }
                    else {
                        $string .= $c;
                    }
                }
                $tag->set_content([$string]);
                push @tags, $tag;
            }
        }
        else {
            push @tags, $tag;
        }
        $current_open_re = join '|', map {
            quotemeta $_->get_name
        } @opened;

    };
    my @class = 'block';
    while (defined $text and length $text) {
        $in_url = grep { $_->get_class eq 'url' } @opened;
        #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$in_url], ['in_url']);
        #warn __PACKAGE__.':'.__LINE__.": ============= match $text\n";
        my $tag;
        my ($before, $tag1, $tag2, $after);
        if ($re_classic and $re_short) {
            ($before, $tag1, $tag2, $after) = split m{
                (?:
                    \[ ($re_short)   (?=://)
                    |
                    \[ ($re_classic) (?=\b|\]|\=)
                )
            }ix, $text, 2;
        }
        elsif (! $re_classic and $re_short) {
            ($before, $tag1, $after) = split m{
                    \[ ($re_short)   (?=://)
            }ix, $text, 2;
        }
        elsif ($re_classic and !$re_short) {
            ($before, $tag2, $after) = split m{
                    \[ ($re_classic) (?=\b|\]|\=)
            }ix, $text, 2;
        }
        { no warnings;
#            warn __PACKAGE__.':'.__LINE__.": $before, $tag1, $tag2, $after)\n";
        #warn __PACKAGE__.':'.__LINE__.": RE: $current_open_re\n";
        }
        #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@opened], ['opened']);
        if (length $before) {
            # look if it contains a closing tag
            #warn __PACKAGE__.':'.__LINE__.": BEFORE $before\n";
            while (length $current_open_re and $before =~ s# (.*?) (\[ / ($current_open_re) \]) ##ixs) {
                # found closing tag
                my ($content, $end, $name) = ($1, $2, $3);
                #warn __PACKAGE__.':'.__LINE__.": found closing tag $name!\n";
                my $f;
                # try to find the matching opening tag
                my @not_close;
                while (@opened) {
                    my $try = pop @opened;
                    $current_open_re = join '|', map {
                        quotemeta $_->get_name
                    } @opened;
                    if ($try->get_name eq lc $name) {
                        $f = $try;
                        last;
                    }
                    elsif (!$try->get_close) {
                        $self->_finish_tag($try, '');
                        unshift @not_close, $try;
                    }
                    else {
                        # unbalanced
                        $self->_add_error('unclosed', $try);
                        if ($self->get_close_open_tags) {
                            # close
                            $f = $try;
                            unshift @not_close, $try;
                            if (@opened) {
                                $opened[-1]->add_content('');
                            }
                            $self->_finish_tag($try, '[/'. $try->get_name() .']', 1);
                        }
                        else {
                            # just add unparsed text
                            $callback_found_tag->($_) for $try->_reduce;
                        }
                    }
                }
                if (@not_close) {
                    $not_close[-1]->add_content($content);
                }
                for my $n (@not_close) {
                    $f->add_content($n);
                    #$callback_found_tag->($n);
                }
                # add text before closing tag as content to the current open tag
                if ($f) {
                    unless (@not_close) {
                        #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$f], ['f']);
                        $f->add_content( $content );
                    }
                    # TODO
                    $self->_finish_tag($f, $end);
                    #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$f], ['f']);
                    $callback_found_tag->($f);
                }
            }
#            warn __PACKAGE__." === before='$before' ($tag)\n";
            $callback_found_text->($before);
        }

        if (defined $tag1) {
            $in_url = grep { $_->get_class eq 'url' } @opened;
            # short tag
#            $callback_found_text->($before) if length $before;
            if ($after =~ s{ :// ([^\[]+) \] }{}x) {
                my $content = $1;
                my ($attr, $title) = split /\|/, $content, 2;
                my $tag = $self->new_tag({
                        name    => lc $tag1,
                        attr    => [[$attr]],
                        attr_raw => $attr,
                        content => [(defined $title and length $title) ? $title : ()],
                        start   => "[$tag1://$content]",
                        close   => 0,
                        class   => $defs->{lc $tag1}->{class},
                        single  => $defs->{lc $tag1}->{single},
                        in_url  => $in_url,
                        type    => 'short',
                    });
                if ($in_url and $tag->get_class eq 'url') {
                    $callback_found_text->($tag->get_start);
                }
                else {
                    $callback_found_tag->($tag);
                }
            }
            else {
                $callback_found_text->("[$tag1");
            }
            $text = $after;
            next;
        }
        $tag = $tag2;


        $in_url = grep { $_->get_class eq 'url' } @opened;

        if ($after) {
            # found start of a tag
            #warn __PACKAGE__.':'.__LINE__.": find attribute for $tag\n";
            my ($ok, $attributes, $attr_string, $end) = $self->$parse_attributes(
                text => \$after,
                tag => lc $tag,
            );
            if ($ok) {
                my $attr = $attr_string;
                $attr = '' unless defined $attr;
                #warn __PACKAGE__.':'.__LINE__.": found attribute for $tag: $attr\n";
                my $close = $defs->{lc $tag}->{close};
                my $def = $defs->{lc $tag};
                my $open = $self->new_tag({
                        name    => lc $tag,
                        attr    => $attributes,
                        attr_raw => $attr_string,
                        content => [],
                        start   => "[$tag$attr]",
                        close   => $close,
                        class   => $defs->{lc $tag}->{class},
                        single  => $defs->{lc $tag}->{single},
                        in_url  => $in_url,
                        type    => 'classic',
                    });
                my $success = 1;
                my $nested_url = $in_url && $open->get_class eq 'url';
                {
                    my $last = $opened[-1];
                    if ($last and not $last->get_close and not $close) {
                        $self->_finish_tag($last, '');
                        # tag which should not have closing tag
                        pop @opened;
                        $callback_found_tag->($last);
                    }
                }
                if ($open->get_single && !$nested_url) {
                    $self->_finish_tag($open, '');
                    $callback_found_tag->($open);
                }
                elsif (!$nested_url) {
                    push @opened, $open;
                    my $def = $defs->{lc $tag};
                    #warn __PACKAGE__.':'.__LINE__.": $tag $def\n";
                    my $parse = $def->{parse};
                    if ($parse) {
                        $current_open_re = join '|', map {
                            quotemeta $_->get_name
                        } @opened;
                    }
                    else {
                        #warn __PACKAGE__.':'.__LINE__.": noparse, find content\n";
                        # just search for closing tag
                        if ($after =~ s# (.*?) (\[ / $tag \]) ##ixs) {
                            my $content = $1;
                            my $end = $2;
                            #warn __PACKAGE__.':'.__LINE__.": CONTENT $content\n";
                            my $finished = pop @opened;
                            $finished->set_content([$content]);
                            $self->_finish_tag($finished, $end);
                            $callback_found_tag->($finished);
                        }
                        else {
                            #warn __PACKAGE__.':'.__LINE__.": nope '$after'\n";
                        }
                    }
                }
                else {
                    $callback_found_text->($open->get_start);
                }

            }
            else {
                # unclosed tag
                $callback_found_text->("[$tag$attr_string$end");
            }
        }
        elsif ($tag) {
            #warn __PACKAGE__.':'.__LINE__.": end\n";
            $callback_found_text->("[$tag");
        }
        $text = $after;
        #sleep 1;
        #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@tags], ['tags']);
    }
#    warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@opened], ['opened']);
    if ($self->get_close_open_tags) {
        while (my $opened = pop @opened) {
            $self->_add_error('unclosed', $opened);
            $self->_finish_tag($opened, '[/' . $opened->get_name . ']', 1);
            $callback_found_tag->($opened);
        }
    }
    else {
        while (my $opened = shift @opened) {
            my @text = $opened->_reduce;
            push @tags, @text;
        }
    }
    if ($scalar_util) {
        Scalar::Util::weaken($callback_found_tag);
    }
    else {
        # just to make sure no memleak if there's no Scalar::Util
        undef $callback_found_tag;
    }
    #warn __PACKAGE__.':'.__LINE__.": !!!!!!!!!!!! left text: '$text'\n";
    #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\@tags], ['tags']);
    my $tree = $self->new_tag({
        name => '',
        content => [@tags],
        start => '',
        class => 'block',
        attr => [[]],
    });
    $tree->_init_info({});
    return $tree;
}

sub new_tag {
    my $self = shift;
    Parse::BBCode::Tag->new(@_)
}

sub _add_error {
    my ($self, $error, $tag) = @_;
    my $errors = $self->get_error || {};
    push @{ $errors->{$error} }, $tag;
    $self->set_error($errors);
}

sub error {
    my ($self, $type) = @_;
    my $errors = $self->get_error || {};
    if ($type and $errors->{$type}) {
        return $errors->{$type};
    }
    elsif (keys %$errors) {
        return $errors;
    }
    return 0;
}

sub render {
    my ($self, $text, $params) = @_;
    if (@_ < 2) {
        croak ("Missing input - Usage: \$parser->render(\$text)");
    }
    #warn __PACKAGE__.':'.__LINE__.": @_\n";
    #sleep 2;
    my $tree = $self->parse($text, $params);
    my $out = $self->render_tree($tree, $params);
    if ($self->get_error) {
        $self->set_tree($tree);
    }
    return $out;
}

sub render_tree {
    my ($self, $tree, $params) = @_;
    $params ||= {};
    $self->set_params($params);
    my $rendered = $self->_render_tree($tree);
    $self->set_params(undef);
    return $rendered;
}

sub _render_tree {
    my ($self, $tree, $outer, $info) = @_;
    my $out = '';
    $info ||= {
        stack   => [],
        tags    => {},
        classes => {},
    };
    my $defs = $self->get_tags;
    if (ref $tree) {
        my $name = $tree->get_name;
        my %tags = %{ $info->{tags} };
        $tags{$name}++;
        my @stack = @{ $info->{stack} };
        push @stack, $name;
        my %classes = %{ $info->{classes} };
        $classes{ $tree->get_class || '' }++;
        my %info = (
            tags => \%tags,
            stack => [@stack],
            classes => \%classes,
        );
        my $code = $defs->{$name}->{code};
        my $parse = $defs->{$name}->{parse};
        my $attr = $tree->get_attr || [];
        $attr = $attr->[0]->[0];
        my $content = $tree->get_content;
        my $fallback;
        my $string = '';
        if (($tree->get_type || 'classic') eq 'classic') {
            $fallback = (defined $attr and length $attr) ? $attr : $content;
        }
        else {
            $fallback = $attr;
            $string = @$content ? '' : $attr;
        }
        if (ref $fallback) {
            # we have recursive content, we don't want that in
            # an attribute
            $fallback = join '', grep {
                not ref $_
            } @$fallback;
        }
        if ($self->get_strip_linebreaks and ($tree->get_class || '') eq 'block') {
            if (@$content == 1 and not ref $content->[0] and defined $content->[0]) {
                $content->[0] =~ s/^\r?\n//;
                $content->[0] =~ s/\r?\n\z//;
            }
            elsif (@$content > 1) {
                if (not ref $content->[0] and defined $content->[0]) {
                    $content->[0] =~ s/^\r?\n//;
                }
                if (not ref $content->[-1] and defined $content->[-1]) {
                    $content->[-1] =~ s/\r?\n\z//;
                }
            }
        }
        if (not exists $defs->{$name}->{parse} or $parse) {
            for my $c (@$content) {
                $string .= $self->_render_tree($c, $tree, \%info);
            }
        }
        else {
            $string = join '', @$content;
        }
        if ($code) {
            my $o = $code->($self, $attr, \$string, $fallback, $tree, \%info);
            $out .= $o;
        }
        else {
            $out .= $string;
        }
    }
    else {
        #warn __PACKAGE__.':'.__LINE__.": ==== $tree\n";
        $out .= $self->_render_text($outer, $tree, $info);
    }
    return $out;
}


sub escape_html {
    my ($str) = @_;
    return '' unless defined $str;
    $str =~ s/&/&/g;
    $str =~ s/"/"/g;
    $str =~ s/'/'/g;
    $str =~ s/>/>/g;
    $str =~ s/
    return $str;
}

sub parse_attributes {
    my ($self, %args) = @_;
    my $text = $args{text};
    my $tagname = $args{tag};
    my $attribute_quote = $self->get_attribute_quote;
    my $attr_string = '';
    my $attributes = [];
    if (
        ($self->get_direct_attribute and $$text =~ s/^(=[^\]]*)?]//)
            or
        ($$text =~ s/^( [^\]]*)?\]//)
    ) {
        my $attr = $1;
        my $end = ']';
        $attr = '' unless defined $attr;
        $attr_string = $attr;
        unless (length $attr) {
            return (1, [], $attr_string, $end);
        }
        if ($self->get_direct_attribute) {
            $attr =~ s/^=//;
        }
        if ($self->get_strict_attributes and not length $attr) {
            return (0, [], $attr_string, $end);
        }
        my @array;
        if (length($attribute_quote) == 1) {
            if ($attr =~ s/^(?:$attribute_quote(.+?)$attribute_quote(?:\s+|$)|(.*?)(?:\s+|$))//) {
                my $val = defined $1 ? $1 : $2;
                push @array, [$val];
            }
            while ($attr =~ s/^([a-zA-Z0-9_]+)=(?:$attribute_quote(.+?)$attribute_quote(?:\s+|$)|(.*?)(?:\s+|$))//) {
                my $name = $1;
                my $val = defined $2 ? $2 : $3;
                push @array, [$name, $val];
            }
        }
        else {
            if ($attr =~ s/^(?:(["'])(.+?)\1|(.*?)(?:\s+|$))//) {
                my $val = defined $2 ? $2 : $3;
                push @array, [$val];
            }
            while ($attr =~ s/^([a-zA-Z0-9_]+)=(?:(["'])(.+?)\2|(.*?)(?:\s+|$))//) {
                my $name = $1;
                my $val = defined $3 ? $3 : $4;
                push @array, [$name, $val];
            }
        }
        if ($self->get_strict_attributes and length $attr and $attr =~ tr/ //c) {
            return (0, [], $attr_string, $end);
        }
        $attributes = [@array];
        return (1, $attributes, $attr_string, $end);
    }
    return (0, $attributes, $attr_string, '');
}

# TODO add callbacks
sub _finish_tag {
    my ($self, $tag, $end, $auto_closed) = @_;
    #warn __PACKAGE__.':'.__LINE__.": _finish_tag(@_)\n";
    #warn __PACKAGE__.':'.__LINE__.$".Data::Dumper->Dump([\$tag], ['tag']);
    unless ($tag->get_finished) {
        $tag->set_end($end);
        $tag->set_finished(1);
        $tag->set_auto_closed($auto_closed || 0);
    }
    return 1;
}

__END__