view release on metacpan or  search on metacpan

lib/Text/Hatena.pm  view on Meta::CPAN

package Text::Hatena;
use strict;
use warnings;
use Carp;
use base qw(Class::Data::Inheritable);
use vars qw($VERSION);
use Parse::RecDescent;
use Text::Hatena::AutoLink;

$VERSION = '0.20';

my ($parser, $syntax);

__PACKAGE__->mk_classdata('syntax');

#$::RD_HINT = 1;
#$::RD_TRACE = 1;
#$::RD_WARN = undef;
$Parse::RecDescent::skip = '';
$syntax = q(
    body       : section(s)
    section    : h3(?) block(s?)
    # Block Elements
    block      : h5
               | h4
               | blockquote
               | dl
               | list
               | super_pre
               | pre
               | table
               | cdata
               | p
    h3         : "\n*" inline(s)
    h4         : "\n**" inline(s)
    h5         : "\n***" inline(s)
    blockquote : "\n>" http(?) ">" block(s) "\n<<" ..."\n"
    dl         : dl_item(s)
    dl_item    : "\n:" inline[term => ':'](s) ':' inline(s)
    list       : list_item[level => $arg{level} || 1](s)
    list_item  : "\n" /[+-]{$arg{level}}/ inline(s) list[level => $arg{level} + 1](?)
    super_pre  : /\n>\|(\w*)\|/o text_line(s) "\n||<" ..."\n"
    text_line  : ...!"\n||<\n" "\n" /[^\n]*/o
    pre        : "\n>|" pre_line(s) "\n|<" ..."\n"
    pre_line   : ...!"\n|<" "\n" inline(s?)
    table      : table_row(s)
    table_row  : "\n|" td(s /\|/) '|'
    td         : /\*?/o inline[term => '\|'](s)
    cdata      : "\n><" /.+?(?=><\n)/so "><" ..."\n"
    p          : ...!p_terminal "\n" inline(s?)
    p_terminal : h3 | "\n<<\n"
    # Inline Elements
    inline     : /[^\n$arg{term}]+/
    http       : /https?:\/\/[A-Za-z0-9~\/._\?\&=\-%#\+:\;,\@\']+(?::title=[^\]]+)?/
);

sub parse {
    my $class = shift;
    my $text = shift or return;
    $text =~ s/\r//g;
    $text = "\n" . $text unless $text =~ /^\n/;
    $text .= "\n" unless $text =~ /\n$/;
    my $node = shift || 'body';
    my $html = $class->parser->$node($text);
#    warn $html;
    return $html;
}

sub parser {
    my $class = shift;
    unless (defined $parser) {
         $::RD_AUTOACTION = q|my $method = shift @item;| .
             $class . q|->$method({items => \@item});|;
        $parser = Parse::RecDescent->new($syntax);
        if ($class->syntax) {
            $parser->Replace($class->syntax);
        }
    }
    return $parser;
}

sub expand {
    my $class = shift;
    my $array = shift or return;
    ref($array) eq 'ARRAY' or return;
    my $ret = '';
    while (my $item = shift @$array) {
        if (ref($item) eq 'ARRAY') {
            my $c = $class->expand($item);
            $ret .= $c if $c;
        } else {
            $ret .= $item if $item;
        }
    }
    return $ret;
}

# Nodes
# Block Nodes
sub abstract {
    my $class = shift;
    my $items = shift->{items};
    return $class->expand($items);
}

*body = \&abstract;
*block = \&abstract;
*line = \&abstract;

lib/Text/Hatena.pm  view on Meta::CPAN

        $tag ||= $li =~ /^\-/ ? 'ul' : 'ol';
        $li =~ s/^[+-]+//;
        $list .= $li;
    }
    return "<$tag>\n$list</$tag>\n";
}

sub list_item {
    my $class = shift;
    my $items = shift->{items};
    my $li = $class->expand($items->[2]);
    my $sl = $class->expand($items->[3]) || '';
    $sl = "\n" . $sl if $sl;
    return $items->[1] . "<li>$li$sl</li>\n";
}

sub super_pre {
    my $class = shift;
    my $items = shift->{items};
    my $filter = $1 || ''; # todo
    my $texts = $class->expand($items->[1]);
    return "<pre>\n$texts</pre>\n";
}

sub pre {
    my $class = shift;
    my $items = shift->{items};
    my $lines = $class->expand($items->[1]);
    return "<pre>\n$lines</pre>\n";
}

sub pre_line {
    my $class = shift;
    my $items = shift->{items};
    my $inlines = $class->expand($items->[2]);
    return "$inlines\n";
}

sub table {
    my $class = shift;
    my $items = shift->{items};
    my $trs = $class->expand($items->[0]);
    return "<table>\n$trs</table>\n";
}

sub table_row { # we can't use tr!
    my $class = shift;
    my $items = shift->{items};
    my $tds = $class->expand($items->[1]);
    return "<tr>\n$tds</tr>\n";
}

sub td {
    my $class = shift;
    my $items = shift->{items};
    my $tag = $items->[0] ? 'th' : 'td';
    my $inlines = $class->expand($items->[1]);
    return "<$tag>$inlines</$tag>\n";
}

sub cdata {
    my $class = shift;
    my $items = shift->{items};
    my $data = $items->[1];
    return "<$data>\n";
}

sub p {
    my $class = shift;
    my $items = shift->{items};
    my $inlines = $class->expand($items->[2]);
    return $inlines ? "<p>$inlines</p>\n" : "\n";
}

sub text_line {
    my $class = shift;
    my $text = shift->{items}->[2];
    return "$text\n";
}

# Inline Nodes
sub inline {
    my $class = shift;
    my $items = shift->{items};
    my $item = $items->[0] or return;
    $item = Text::Hatena::AutoLink->parse($item);
    return $item;
}

sub http {
    my $class = shift;
    my $items = shift->{items};
    my $item = $items->[0] or return;
    $item =~ s/:title=([^\]]+)$//;
    my $title = $1 || $item;
    return {
        cite => $item,
        title => $title,
    }
}

1;

__END__

=head1 NAME

Text::Hatena - Perl extension for formatting text with Hatena Style.

=head1 SYNOPSIS

  use Text::Hatena;

  my $html = Text::Hatena->parse($text);

=head1 DESCRIPTION

Text::Hatena parses text with Hatena Style and generates html string.
Hatena Style is a set of text syntax which is originally used in
Hatena Diary (http://d.hatena.ne.jp/).