File Coverage

blib/lib/HTML/ForumCode.pm

Criterion	Covered	Total	%
statement	69	71	97.1
branch	6	8	75.0
condition	1	3	33.3
subroutine	18	18	100.0
pod	3	3	100.0
total	97	103	94.1

package HTML::ForumCode;
# vim: ts=8 sts=4 et sw=4 sr sta
use strict;
use warnings;

use version; our $VERSION = qv('0.0.5')->numify;

use Template::Plugin::HTML;

sub new {
    my ($class, @args) = @_;

    my $new_obj = bless {}, (ref($class)||$class);
    $new_obj->init;

    return $new_obj;
}

sub init {
    my $self = shift;

    # simple [x][/x] -->  tags
    $self->{simple_tags} = [qw{
        b
        u
        i
    }];
    # replacements; e.g. __x__ --> x
    $self->{replacements} = [
        {   from => '__',       to => 'u'   },
        {   from => '\*\*',     to => 'b'   },
    ];

    return;
}

sub forumcode {
    my ($self, $text) = @_;

    # if we don't have any text, we don't have to do any work
    if (not defined $text) {
        return q{};
    }

    # first of all ESCAPE EVERYTHING!
    $text = Template::Plugin::HTML->escape($text);

    # turn newlines into  tags
    $self->_preserve_newlines(\$text );

    $self->_simple_tags     ( \$text );
    $self->_replacements    ( \$text );
    $self->_colouring       ( \$text );
    $self->_lists           ( \$text );
    $self->_url_links       ( \$text );
    $self->_images          ( \$text );
    $self->_styled_block    ( \$text );
    $self->_quoted_block    ( \$text );

    return $text;
}

sub _preserve_newlines {
    my ($self, $textref) = @_;

    $$textref =~ s{\n}{}xmsg;
}

sub _simple_tags {
    my ($self, $textref) = @_;

    # deal with acceptable [x]...[/x] markup
    foreach my $tag (@{ $self->{simple_tags} }) {
        # we should be able to combine these two into one
        #$$textref =~ s{\[$tag\]}{<$tag>}g;
        #$$textref =~ s{\[/$tag\]}{}g;
        $$textref =~ s{
            \[($tag)\]
            (.+?)
            \[/$tag\]
        }
        {<$1>$2}xmsg;
    }
}

sub _replacements {
    my ($self, $textref) = @_;

    # now deal with replacements
    foreach my $tag (@{ $self->{replacements} }) {
        $$textref =~ s{
            $tag->{from}
            (.+?)
            $tag->{from}
        }
        {<$tag->{to}>$1{to}>}gx;
    }
}

sub _url_links {
    my ($self, $textref) = @_;

    # deal with links with no text-label
    $$textref =~ s{\[url\](.+?)\[/url\]}
        {$1}xmsg;
    # deal with links with a text-label
    $$textref =~ s{
        \[url           # start of url tag
        \s+             # need some whitespace
        name="     # name="
        (.+?)           # the name
        "          # closing "
        \s*             # optional whitespace
        \]              # close the opening tag
        (.+?)           # the url
        \[/url\]        # close the URL tag
    }
    {$1}xmsg;
    # bbcode / explosm style urls
    $$textref =~ s{
        \[URL="    # opening url tag
        (.+?)           # the url
        "\]        # close-opening tag
        (.+?)           # link name/text/label
        \[/URL]         # closing tag
    }
    {$2}ximsg;
}

sub _images {
    my ($self, $textref) = @_;

    # deal with image tags
    $$textref =~ s{
        \[img           # opening img tag
        (.*?)           # optional parameters
        \]              # close-opening tag
        (.+?)           # image URL
        \[/img\]        # closing img tag
    }
    #{}ximsg;
    {&_image_tag_with_attr($2,$1)}ximsge;
}

sub _image_tag_with_attr {
    my ($uri, $attr_match) = @_;

    # no annoying image attributes to worry about
    if (q{} eq $attr_match) {
        return qq{};
    }
    # deal with annoying image attributes
    else {
        $attr_match =~ s{
            (\w+)
            =
            "
            (\w+?)
            "
        }
        {$1="$2"}xmsg;
        return qq{};
    }
}

sub _colouring {
    my ($self, $textref) = @_;

    # deal with colouring
    $$textref =~ s{
        \[(colou?r)
        =
        (
              red | orange | yellow | green | blue
            | black | white
            | \#[0-9a-fA-F]{3}
            | \#[0-9a-fA-F]{6}
        )
        \]
        (.+?)
        \[/\1\]
    }
    {$3}ixmsg;
}

sub _lists {
    my ($self, $textref) = @_;

    $$textref =~ s{
        \[list\]
        (?:
            \s*
            (?:

            )?
            \s*
        )
        (.+?)
        \[/list\]
        [\s]*
        (?:

        )?
    }
    {_list_elements($1)}xmsge;
}

sub _list_elements {
    my ($text) = @_;

    # ordered lists
    if (
        $text =~ s{
            \[\*\]
            \s*
            (.+?)

            \s*
        }
        {$1}xmsg
    ) {
        return qq{$text};
    }

    # ordered lists
    if (
        $text =~ s{
            \[1\]
            \s*
            (.+?)

            \s*
        }
        {$1}xmsg
    ) {
        return qq{$text};
    }


    # otherwise, just return what we were given
    return $text;
}

sub _styled_block {
    my ($self, $textref) = @_;

    $$textref =~ s{
        \[(code|pre|quote)\]
        (.+?)
        \[/\1\]
    }
    {$2}xmsg;
}

# this deals with the extended case of [quote] where we have the quoting=
# attribute
sub _quoted_block {
    my ($self, $textref) = @_;

    $$textref =~ s{
        \[
            (quote)
            \s+
            quoting=
            "
            (.+?)
            "
        \]
        (.+?)
        \[/\1\]
    }
    {Quoting $2:$3}xmsg;
}

1;
__END__