HTML::SBC - simple blog code for valid (X)HTML

    use HTML::SBC;
    my $translator  = HTML::SBC->new();
    my $html        = $translator->sbc($text);

    use HTML::SBC qw(sbc_translate);
    my $html = sbc_translate($text);

    use HTML::SBC qw( sbc_translate );
    HTML::SBC::german();
    my ($html, $errors) = sbc_translate($text);
    print "$_\n" for @$errors;

    use HTML::SBC qw( sbc_translate sbc_description );

    use HTML::SBC qw( :vintage );

    [
    \[...\] the three great virtues of a programmer:
    - laziness,
    - impatience and
    - hubris.
    ] Larry Wall

    perldoc HTML::SBC

package HTML::SBC;

our $VERSION = '0.15';

use warnings;
use strict;
use Carp;
use Scalar::Util    qw( blessed );
use Exporter;

# "vintage" interface
my @vintage = qw(
    sbc_translate sbc_translate_inline sbc_quote sbc_description
);
use base qw( Exporter );
our @EXPORT_OK = (@vintage, );
our %EXPORT_TAGS = (all => \@EXPORT_OK, vintage => \@vintage);

my @lang = qw( english german );

{
my %defaults = (
    language            => $lang[0],
    image_support       => undef,
    error_callback      => undef,
    linkcheck_callback  => undef,
    imgcheck_callback   => undef,
);

sub new {
    my ($class, $args) = @_;
    $args ||= {};
    croak 'Arguments expected as hash ref' if ref $args ne 'HASH';
    my $self = bless { %defaults, %$args }, $class;
    $self->_init;
    return $self;
}
} # end of lexical %defaults

sub _init {
    my ($self) = @_;
    $self->{text}       =  '';
    $self->{result}     =  '';
    $self->{attribute}  =  '';
    $self->{errors}     = [ ];
    $self->{istack}     = { };
    $self->{qstack}     =   0;
    $self->{line}       =   0;
}

# private error reporting sub
{
my %error = (
    no_quote_end => {
        $lang[0]    => q(No quote end tag ']'),
        $lang[1]    => q(Kein Zitatende-Zeichen ']'),
    },
    no_emphasis_end => {
        $lang[0]    => q(No emphasis end tag '*'),
        $lang[1]    => q(Kein Betonungs-Endezeichen '*'),
    },
    no_strong_end => {
        $lang[0]    => q(No strong end tag '_'),
        $lang[1]    => q(Kein Hervorhebungs-Endezeichen '_'),
    },
    no_hyperlink_end => {
        $lang[0]    => q(No hyperlink end tag '>'),
        $lang[1]    => q(Kein Hyperlink-Endezeichen '>'),
    },
    no_image_end => {
        $lang[0]    => q(No image end tag '}'),
        $lang[1]    => q(Kein Bild-Endezeichen '}'),
    },
    forbidden_url => {
        $lang[0]    => q(Forbidden URL),
        $lang[1]    => q(Verbotener URL),
    },
    unknown_token => {
        $lang[0]    => q(Unknown token),
        $lang[1]    => q(Unbekanntes Zeichen),
    },
    line => {
        $lang[0]    => q(around logical line),
        $lang[1]    => q(um logische Zeile),
    },
);

sub _error {
    my ($self, $error, $arg) = @_;
    my $string = join ' ', (
        $error{$error}{$self->language()},
        ($arg) x ! ! $arg, # additional information to this error message
        $error{line}{$self->language()},
        $self->{line},
    );
    push @{ $self->{errors} }, $string;
    $self->_error_callback($string, $self);
}
} # end of lexical %error

sub _error_callback {
    my ($self, @args) = @_;
    $self->{error_callback}->(@args) if defined $self->{error_callback};
}

sub _linkcheck_callback {
    my ($self, @args) = @_;
    if (defined $self->{linkcheck_callback}) {
        return $self->{linkcheck_callback}->(@args);
    }
    return 1; # all URIs are valid by default
}

sub _imgcheck_callback {
    my ($self, @args) = @_;
    if (defined $self->{imgcheck_callback}) {
        return $self->{imgcheck_callback}->(@args);
    }
    return 1; # all IMG URIs are valid by default
}
    
# basic html things
sub _pre {
    my ($self) = @_;
    $self->{text} =~ s/&/&/g;
    $self->{text} =~ s/\\</&lt;/g;
    $self->{text} =~ s/\\>/&gt;/g;
    $self->{text} =~ s/"/&quot;/g;
    $self->{text} =~ s/[\t ]+/ /g;
}

# make clean...
sub _post {
    my ($self) = @_;
    $self->{result} =~ s/\\([*_<>{}\[\]#\\])/$1/g;
}

# tokenizer
{
my %token = (
    EMPHASIS        =>  qr{^\*},
    STRONG          =>  qr{^_},
    HYPERLINK_START =>  qr{^<(https?://[^ >\n]+) *},
    HYPERLINK_END   =>  qr{^>},
    IMAGE_START     =>  qr|^\{(https?://[^ }\n]+) *|,
    IMAGE_END       =>  qr|^\}|,
    QUOTE_START     =>  qr{^\n+\[\n?},
    QUOTE_END       =>  qr{^\] *\n+},
    QUOTE_END_CITE  =>  qr{^\] *},
    UL_BULLET       =>  qr{^\n+- *},
    OL_BULLET       =>  qr{^\n+# *},
    LINEBREAK       =>  qr{^\n+},
    PLAIN           =>  qr{^((?:[^*_<>\{\}\[\]#\\\n]+|\\[*_<>\{\}\[\]#\\\n])*)},
);

sub _literal {
    my ($self, $token, $replacement) = @_;
    $replacement = '' unless defined $replacement;
    my $regex = $token{$token};

    my $success = $self->{text} =~ s/$regex/$replacement/;
    $self->{attribute} = $1 || undef;
    return $success;
}
} # end of lexical %token

# parser...
sub _sbc {
    my ($self) = @_;
    my $sbc = '';
    while (my $block = $self->_block()) {
        $sbc .= $block;
    }
    return $sbc;
}

sub _block {
    my ($self) = @_;
    return( $self->_quote()
        or  $self->_ulist()
        or  $self->_olist()
        or  $self->_paragraph()
    );
}

sub _quote {
    my ($self) = @_;
    $self->_literal('QUOTE_START', "\n") or return;

    $self->{line}++;
    $self->{qstack}++;
    my $quote = $self->_sbc();
    $self->{qstack}--;

    if ($self->_literal('QUOTE_END', "\n")) {
        return qq(<div class="quote">)
            .  qq(<blockquote>\n$quote</blockquote></div>\n);
    }
    elsif ($self->_literal('QUOTE_END_CITE')) {
        my $cite = $self->_inline();
        return qq(<div class="quote"><cite>$cite</cite>)
            .  qq(<blockquote>\n$quote</blockquote></div>\n);
    }
    else {
        $self->_error('no_quote_end');
        return qq(<div class="quote">)
            .  qq(<blockquote>\n$quote</blockquote></div>\n);
    }
}

sub _ulist {
    my ($self) = @_;
    my $ulist = '';
    while (my $ulitem = $self->_ulitem()) {
        $ulist .= $ulitem;
    }
    return if $ulist eq '';
    return qq(<ul>\n$ulist</ul>\n);
}

sub _ulitem {
    my ($self) = @_;
    $self->_literal('UL_BULLET') or return;
    $self->{line}++;
    my $ulitem = $self->_inline();
    return qq(\t<li>$ulitem</li>\n);
}

sub _olist {
    my ($self) = @_;
    my $olist = '';
    while (my $olitem = $self->_olitem()) {
        $olist .= $olitem;
    }
    return if $olist eq '';
    return qq(<ol>\n$olist</ol>\n);
}

sub _olitem {
    my ($self) = @_;
    $self->_literal('OL_BULLET') or return;
    $self->{line}++;
    my $olitem = $self->_inline();
    return qq(\t<li>$olitem</li>\n);
}

sub _paragraph {
    my ($self) = @_;
    $self->_literal('LINEBREAK') or return;
    $self->{line}++;
    my $paragraph = $self->_inline();

    unless ($self->{qstack} or $self->_literal('LINEBREAK', "\n")) {
        $self->{line}--;
        return;
    }
    if ($paragraph =~ /^\s*$/) {
        return "\n";
    }
    else {
        return qq(<p>$paragraph</p>\n);
    }
}

sub _inline {
    my ($self) = @_;
    my $inline = '';

    while (1) { # use Acme::speeed to accelerate this!
        if (not $self->{istack}{EMPHASIS} and
            defined(my $emphasis = $self->_emphasis())) {
                $inline .= $emphasis; next;
        }
        elsif (not $self->{istack}{STRONG} and
               defined(my $strong = $self->_strong())) {
                $inline .= $strong; next;
        }
        elsif (not $self->{istack}{HYPERLINK} and
               defined(my $hyperlink = $self->_hyperlink())) {
                $inline .= $hyperlink; next;
        }
        elsif ($self->image_support() and
               defined(my $image = $self->_image())) {
                $inline .= $image; next;
        }
        elsif (defined(my $plain = $self->_plain())) {
                $inline .= $plain; next;
        }
        else {
                last;
        }
    }

    return $inline;
}

sub _emphasis {
    my ($self) = @_;
    $self->_literal('EMPHASIS') or return;
    $self->{istack}{EMPHASIS}++;
    my $emphasis = $self->_inline();
    $self->_literal('EMPHASIS') or $self->_error('no_emphasis_end');
    $self->{istack}{EMPHASIS}--;
    return '' if $emphasis eq '';
    return qq(<em>$emphasis</em>);
}

sub _strong {
    my ($self) = @_;
    $self->_literal('STRONG') or return;
    $self->{istack}{STRONG}++;
    my $strong = $self->_inline();
    $self->_literal('STRONG') or $self->_error('no_strong_end');
    $self->{istack}{STRONG}--;
    return '' if $strong eq '';
    return qq(<strong>$strong</strong>);
}

sub _hyperlink {
    my ($self) = @_;
    $self->_literal('HYPERLINK_START') or return;
    $self->{istack}{HYPERLINK}++;
    my $url = $self->{attribute};
    my $link = $self->_inline();
    $link = $url if $link =~ /^ *$/;
    $self->_literal('HYPERLINK_END') or $self->_error('no_hyperlink_end');
    $self->{istack}{HYPERLINK}--;
    if ($self->_linkcheck_callback($url)) {
        return qq(<a href="$url">$link</a>);
    }
    else {
        $self->_error('forbidden_url', $url);
        return $link;
    }
}

sub _image {
    my ($self) = @_;
    $self->_literal('IMAGE_START') or return;
    my $url = $self->{attribute};
    my $alt = '';
    while (my $plain = $self->_plain()) {
        $alt .= $plain;
    }
    $self->_literal('IMAGE_END') or $self->_error('no_image_end');
    if ($self->_imgcheck_callback($url)) {
        return qq(<img src="$url" alt="$alt">);
    }
    else {
        $self->_error('forbidden_url', $url);
        return '';
    }
}

sub _plain {
    my ($self) = @_;
    $self->_literal('PLAIN') and return $self->{attribute};
}

{
# accessor checks
my %checks = (
    language            => sub { my ($l) = @_;
        scalar grep { $_ eq $l } @lang
    },
    image_support       => sub {
        1;
    },
    error_callback      => sub {
        ! blessed($_[0]) && ref $_[0] eq 'CODE' || ! defined $_[0] 
    },
    linkcheck_callback  => sub {
        ! blessed($_[0]) && ref $_[0] eq 'CODE' || ! defined $_[0]
    },
    imgcheck_callback   => sub {
        ! blessed($_[0]) && ref $_[0] eq 'CODE' || ! defined $_[0]
    },
);

# accessor generation
while (my ($field, $valid) = each %checks) {
    no strict 'refs';
    *$field = sub {
        my $self = shift;
        if (@_) {
            my $new = shift;
            if (defined $valid and not $valid->($new)) {
                croak "Invalid value for $field: $new";
            }
            $self->{$field} = $new;
        }
        return $self->{$field};
    };
}
} # end of lexical %check

sub sbc {
    my ($self, $text) = @_;
    return undef unless defined $text;
    return '' if $text =~ /^\s*$/;
    $self->_init();
    $self->{text} = $text;
    $self->_pre();
    $self->{text} = "\n$self->{text}\n";
    $self->{text} =~ s/[\r\n]+/\n/g;
    $self->{result} = $self->_sbc();
    $self->_post();
    $self->{result} =~ s/\\\n/<br>/g;
    $self->_error('unknown_token') unless $self->{text} =~ /^\n*$/;
    return $self->{result};
}

sub sbc_inline {
    my ($self, $text) = @_;
    return undef unless defined $text;
    return '' if $text =~ /^\s*$/;
    $self->_init();
    $self->{text} = $text;
    $self->_pre();
    $self->{text} =~ s/[\r\n]+/ /g;
    $self->{result} = $self->_inline();
    $self->_post();
    $self->_error('unknown_token') unless $self->{text} =~ /^\n*$/;
    return $self->{result};
}

sub errors {
    my ($self) = @_;
    return @{$self->{errors}};
}

sub next_error {
    my ($self) = @_;
    return shift @{ $self->{errors} };
}

sub quote {
    my ($class, $sbc, $cite) = @_;
    $cite = '' unless defined $cite;
    return qq([\n$sbc\n]$cite\n);
}

sub remove_hyperlinks {
    my ($class, $sbc) = @_;
    $sbc =~ s{<(https?://[^ >\n]+)>}{$1}g;
    $sbc =~ s{<https?://[^ >\n]+ +([^>\n]*)>}{$1}g;
    $sbc =~ s{\{https?://[^ \}\n]+\}}{}g;
    $sbc =~ s{\{https?://[^ \}\n]+ +([^\}\n]*)\}}{$1}g;
    return $sbc;
}

{
my %desc = (
    $lang[0] => <<DESC_EN,
Simple Blog Code is easy. Paragraphs are directly translated in paragraphs. Codes in paragraphs:
- _\\*foo\\*_ emphasis: *foo*
- _\\_bar\\__ strong emphasis: _bar_
- _\\<http://www.example.org\\>_ hyperlinks with its URL as text: <http://www.example.org>
- _\\<http://www.example.org baz\\>_ hyperlinks with *baz* as text: <http://www.example.org baz>
- _\\{http://www.memowe.de/pix/sbc.jpg\\}_ images without alternative text (*may be disabled*).
- _\\{http://www.memowe.de/pix/sbc.jpg SBC\\}_ images with alternative text *SBC* (*may be disabled*).
You can use unordered lists:
_- one thing\\
- another thing_
will be
- one thing
- another thing
Or ordered lists:
_\\# first\\
\\# second_
will be
# first
# second
In lists you can use the codes from paragraphs. With square brackets one can mark up quotes. A _\\[Quote\\]_ looks like this:
[Quote]
Or you can add the quote's author after the closing bracket: _\\[Quote\\] Author_:
[Quote] Author
A quote may contain paragraphs, lists and quotes. Author information may contain all codes from paragraphs. Special characters from SBC have to be *escaped* with a backslash: _\\\\\\*_, _\\\\\\__, ...; even the backslash itself: _\\\\\\\\_.
DESC_EN
    $lang[1] => <<DESC_DE,
Simple Blog Code ist einfach. Absätze werden direkt in Absätze übersetzt. Codes in Absätzen:
- _\\*foo\\*_ Betonte Texte: *foo*
- _\\_bar\\__ Hervorgehobene Texte: _bar_
- _\\<http://www.example.org\\>_ Hyperlinks mit Adresse als Text: <http://www.example.org>
- _\\<http://www.example.org baz\\>_ Hyperlinks mit *baz* als Text: <http://www.example.org baz>
- _\\{http://www.memowe.de/pix/sbc.jpg\\}_ Bilder ohne alternativen Text (*möglicherweise deaktiviert*).
- _\\{http://www.memowe.de/pix/sbc.jpg SBC\\}_ Bilder mit alternativem Text *SBC* (*möglicherweise deaktiviert*).
Statt Absätzen kann man ungeordnete Listen verwenden:
_- Einerseits\\
- Andererseits_
wird zu
- Einerseits
- Andererseits
Oder geordnete Listen:
_\\# Erstens\\
\\# Zweitens_
wird zu
# Erstens
# Zweitens
Innerhalb von Listen können die Codes von Absätzen verwendet werden. Mit eckigen Klammern kann man Zitate auszeichnen. Ein _\\[Zitat\\]_ sieht so aus:
[Zitat]
Man kann auch die Quelle des Zitats angeben, nämlich hinter der schließenden eckigen Klammer: _\\[Zitat\\]_ Quelle
[Zitat] Quelle
Ein Zitat kann wieder Absätze, Listen und Zitate enthalten, in Quellenangaben können alle Codes verwendet werden, die auch Absätze kennen. Sonderzeichen von SBC müssen mit einem Backslash codiert werden: _\\\\\\*_, _\\\\\\__, usw. und auch der Backslash selbst: _\\\\\\\\_.
DESC_DE
);

sub description {
    my ($class, $lang) = @_;
    $lang = $lang[0] unless defined $lang;
    croak "Unknown language '$lang'" unless grep { $lang eq $_ } @lang;
    return scalar sbc_translate($desc{$lang});
}
} # end of lexical %desc

{
my $static_transl; # for vintage interface

sub _static {
    unless (defined $static_transl) {
        $static_transl = HTML::SBC->new({
            image_support   => 0, # no image support in versions < 0.10
        });
    }
    return $static_transl;
}
} # end of lexical $static_transl

sub _static_lang {
    my $transl = _static();
    return $transl->language();
}

foreach my $lang (@lang) {
    no strict 'refs';
    *$lang = sub {
        my $static_obj = _static();
        $static_obj->language($lang);
    };
}

sub sbc_translate {
    my ($text) = @_;
    my $transl = _static();
    my $result = $transl->sbc($text);
    my @errors = $transl->errors();
    return wantarray ? ($result, \@errors) : $result;
}

sub sbc_translate_inline {
    my ($line) = @_;
    my $transl = _static();
    my $result = $transl->sbc_inline($line);
    my @errors = $transl->errors();
    return wantarray ? ($result, \@errors) : $result;
}

sub sbc_quote {
    my ($sbc, $cite) = @_;
    return HTML::SBC->quote($sbc, $cite);
}

sub sbc_description {
    return HTML::SBC->description(_static_lang());
}

1; # End of HTML::SBC