root/veekun/trunk/lib/Vee/BBCode.pm

package Vee::BBCode;

use strict;
use warnings;

=head1 NAME

Vee::BBCode - Two-step bbcode parser

=head1 SYNOPSIS

    use Vee::BBCode;
    Vee::BBCode::validate_bbcode('I [i]really[/i] think you should [b]stop[/b].');       # success
    Vee::BBCode::validate_bbcode('Nested [b]tags [i]are not[/b] that[/i] complicated');  # failure
    
    Vee::BBCode::apply_bbcode('[i]Always[/i] [code]use strict;[/code]!');  # HTMLized

=head1 DESCRIPTION

Quick authorization module, to check whether the currently logged-in user has
been given a particular permission.

=head1 METHODS

=cut

# keys are the tag names
# start/end subs take one parameter: the tag's parameter
# replace subs take two parameters: the tag's contents and its parameter
# TODO:
#  - docs?
# BUGS:
#  - replace won't work with no_close
our %tags = (
    b       => { param => 0, start => '<strong class="bbcode-b">', end => '</strong>' },
    i       => { param => 0, start => '<em class="bbcode-i">', end => '</em>' },
    u       => { param => 0, start => '<span class="bbcode-u">', end => '</span>' },
    s       => { param => 0, start => '<span class="bbcode-s">', end => '</span>' },
    h       => { param => 0, start => '<span class="bbcode-h">', end => '</span>' },
    color   => { param => 2, strip_quotes => 1, start => sub {
        my $color = shift;
        if ($color !~ /
            \#[0-9a-f]{3,6}
            | (?:rgb|hsl) \( \s* \d{,3}% \s* , \s* \d{,3}% \s* , \s* \d{,3}% \s* \)
            | (?:rgb|hsl) \( \s* \d{,3}  \s* , \s* \d{,3}  \s* , \s* \d{,3}  \s* \)
            | (?:rgb|hsl)a \( \s* -?\d+  \s* , \s* \d{,3}% \s* , \s* \d{,3}% \s* , \s* \d(\.\d+)? \s* \)
            | [a-z]+[0-9]*
         /ix) { $color = 'inherit' }
        qq'<span class="bbcode-color" style="color: $color;">'
    }, end => '</span>' },
#    size    => { param => 2, },
    url     => { param => 1, strip_quotes => 1, replace => sub { qq'<a href="@{[ $_[0] ? $_[0] : $_[1] ]}" class="bbcode-url">$_[1]</a>' }  },
    img     => { param => 1, strip_quotes => 1, raw => 1, start => sub { $_[0] ? qq'<img src="$_[0]" alt="' : '<img alt="" src="' }, end => '" class="bbcode-img"/>' },
    code    => { param => 1, raw => 1, start => sub { '<div class="bbcode-code-heading">' . ($_[0] ? "Code for $_[0]" : 'Code') . ':</div><div class="bbcode-code">' }, end => '</div>' },
    quote   => { param => 1, start => sub { '<div class="bbcode-quote-heading">' . ($_[0] ? "Quote from $_[0]" : 'Quote') . ':</div><div class="bbcode-quote">' }, end => '</div>' },
    mono    => { param => 1, start => '<span class="bbcode-prop">', end => '</span>' },
    raw     => { param => 1, raw => 1, start => '', end => '' },
    hr      => { param => 0, no_close => 1, start => '<hr class="bbcode-hr"/>' },
    center  => { param => 0, no_close => 0, start => '<div class="bbcode-center">', end => '</div>' },
#    list    => { param => 1, contents => { '*' => 1 }, },
#    '*'     => { param => 0, container => { list => 1 }, self_closing => 1, },
);

# change start, end, and replaces to subroutines for ease of runnage
for my $tag_data (values %tags) {
    for my $replacement (qw/start end replace/) {
        my $format = $tag_data->{ $replacement };
        next unless defined $format;
        next if ref $format;
        $tag_data->{ $replacement } = sub { sprintf $format, @_ };
    }
}

=head2 apply_bbcode

Applies bbcode formatting to a text string.  This makes no attempt to verify
the well-formed-ness of the input.

=cut

sub apply_bbcode {
    my $input = shift;

    for my $tag (keys %tags) {
        if (exists $tags{$tag}{replace}) {
            while ($input =~ / \[ $tag ( = .+? )? \] /sx) {
                # .* at the beginning ensures we catch innermost nestings first
                $input =~ s: (.*) \[ $tag \] (.+?) \[ / $tag \] : $1 . $tags{$tag}{replace}->(undef, $2) :gexis;
                $input =~ s: (.*) \[ $tag = (.+?) \] (.+?) \[ / $tag \] : $1 . $tags{$tag}{replace}->($2, $3) :gexis;
            }
        } else {
            $input =~ s: \[ $tag \] : $tags{$tag}{start}->() :gexi;
            $input =~ s: \[ $tag = (.+?) \] : $tags{$tag}{start}->($1) :gexi;
            $input =~ s: \[ / $tag \] : $tags{$tag}{end}->() :gexi;
        }
    }
    
    $input =~ s:\x0D\x0A:<br/>:g;
    $input =~ s:\x0D|\x0A:<br/>:g;
    
    return $input;
}

=head2 apply_bbcode

Attempts to gauge whether a provided string of bbcode is valid.  Returns the
string, possibly modified (I forget), and a list of errors if applicable.

This method is in transition at the moment, sorry.

=cut

sub validate_bbcode {
    my $input = shift;

    $input =~ s/&/&amp;/g;
    $input =~ s/&amp;(#x?[0-9a-f]{1,10});/&$1;/gi;
    $input =~ s/\"/&quot;/g;
    $input =~ s/</&lt;/g;
    $input =~ s/>/&gt;/g;

    my @tag_stack;
#    my @closed_tag_stack;

    my $lb_entity = '&#91;';
    my $rb_entity = '&#93;';
    my @output = ('');
    my @errors;
    my @replace_params;
    my $pos = 0;
    my ($left_bracket, $right_bracket);
    PARSE: while ($input) {
        $left_bracket  = index $input, '[';                      last if $left_bracket  == -1;
        $right_bracket = index $input, ']', $left_bracket + 1;   last if $right_bracket == -1;
        $left_bracket = rindex $input, '[', $right_bracket;
        my $tag = substr $input, $left_bracket + 1, $right_bracket - $left_bracket - 1;
        
        # tack any plaintext before the next tag onto the output
        my $raw = substr $input, 0, $left_bracket;
        $raw =~ s/ \[ /$lb_entity/gx;
        $raw =~ s/ \] /$rb_entity/gx;
        $output[-1] .= $raw;
        # then remove the preceding plaintext and the tag from the input
        substr($input, 0, $right_bracket + 1) = '';

        $left_bracket = 0;
        $right_bracket -= $left_bracket;

        my $closing = 0;
        if ('/' eq substr $tag, 0, 1) {
            $closing = 1;
            $tag = substr $tag, 1;
        }

        my ($tag_name, $param) = split /=/, $tag, 2;

        # check: skip the tag if it's not one of ours
        if (!exists $tags{$tag_name}) {
            $output[-1] .= $lb_entity . ($closing ? '/' : '') . $tag . $rb_entity;
            next;
        }

        if ($param and $tags{$tag_name}{strip_quotes}) {
            $param =~ s/^&quot;|&quot;$//g;
        }

        # check: can't have a param with a closing tag
        if ($param && $closing) {
            push @errors, [ "Parameter given on closing tag '$tag_name'", $left_bracket + 1 + length $tag ];
            substr($input, $left_bracket + length($tag) + 2, length($param) + 1) = '';
            $param = '';
        }

        # check if parameter should be here
        if (!$closing and $param and $tags{$tag_name}{param} == 0) {
            push @errors, [ "Parameter given for parameter-less tag '$tag_name'", $left_bracket + 1 + length $tag ];
            $param = undef;
        }
        if (!$closing and!$param and $tags{$tag_name}{param} == 2) {
            push @errors, [ "Parameter required for tag '$tag_name'", $left_bracket + 1 + length $tag ];
            $param = '';
        }

        if ($tags{$tag_name}{no_close}) {
            # don't do anything
        } elsif (!$closing) {
            push @tag_stack, $tag_name;
        } else {
            # check tag closing order
            my $next_tag;
            while ($next_tag = pop @tag_stack) {
                last if $next_tag eq $tag_name;

                push @errors, [ "Tag '$tag_name' not closed before parent tag '$next_tag'", $left_bracket ];
                $output[-1] .= qq'<span class="bbcode-error-wrongorder">[/$tag_name]</span>';
            }

            if (!defined $next_tag) {
                # we have run out of initial closing tags!  replace this with something temporary for now
                push @errors, [ "Tag '$tag_name' closed but not open", $left_bracket ];
                $output[-1] .= qq'<span class="bbcode-error-notopen">[/$tag_name]</span>';
                next PARSE;
            }
        }

        $output[-1] .= '[';
        $output[-1] .= '/' if $closing;
        $output[-1] .= $tag;
        $output[-1] .= ']';

        # if the tag is marked as 'raw', then its entire contents should be moved directly to output
        if ($tags{$tag_name}{raw} and !$closing) {
            my $raw_end = index $input, "[/$tag_name]";
            my $raw = substr $input, 0, $raw_end;
            $raw =~ s/ \[ /$lb_entity/gx;
            $raw =~ s/ \] /$rb_entity/gx;
            $output[-1] .= $raw;
            $input = substr $input, $raw_end;
        }
    }
    
    for (@tag_stack) {
        push @errors, [ "Tag '$_' never closed" ];
    }

    if ($input) {
        $input =~ s/ \[ /$lb_entity/gx;
        $input =~ s/ \] /$rb_entity/gx;
        $output[-1] .= $input;
    }
    
    return $output[-1], @errors;
}

=head1 AUTHOR

Maintainer: Alex "Eevee" Munroe (C<veekun@veekun.com>)

See the included F<AUTHORS> file for a full list of contributers.

=head1 LICENSE

See the included F<LICENSE> file.

=cut

1;