view release on metacpan or  search on metacpan

lib/Parse/BBCode.pm  view on Meta::CPAN

                    else {
                        $content = $post_processor->($content);
                    }
                    $content =~ s/\r?\n|\r/<br>\n/g if $linebreaks;
                    $content;
                };
            }
            else {
                $plain = sub {
                    my ($parser, $attr, $content, $info) = @_;
                    my $text = $post_processor->($content, $info);
                    $text =~ s/\r?\n|\r/<br>\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

lib/Parse/BBCode.pm  view on Meta::CPAN

                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']);