Modle::Pluggable使ってはてブみたいなMetaCommentパースをプラグインで対応してみる

かぜぶろさんのはてなブックマークのコメント欄のようなものをParseするモジュール : blog.nomadscafe.jpとid:lestrratさんのClass::DBI::Loader + Module::Pluggableにインスパイヤされてみました。インスパイヤというよりはModule::Pluggable使ってみたかっただけですが。
今回ははてブ方式([tag1][tag2][tag3]comment)以外にタグ情報をスペース区切り([tag1 tag2 tag3]comment)な感じのものに対応させるために、コメントパース部をModule::Pluggableでpluginさせてみます。
インターフェースはこんな感じ。parse引数をひとつ増やしてパースプラグインを指定します。

#!/usr/local/bin/perl
use strict;
use warnings;
use lib "/home/koyachi/lib";

use Text::MetaComment;
use Text::MetaComment::Result;

my $meta_comment = Text::MetaComment->parse( '[tag1 tag2 tag3 tag4]Comment body.' );
print join ", ", $meta_comment->tags, "\n";
print $meta_comment->comment, "\n";

print "##### Hatena style ###\n";
$meta_comment = Text::MetaComment->parse( '[tag1][tag2][tag3][tag4]Comment body.', 'Hatena' );
print join ", ", $meta_comment->tags, "\n";
print $meta_comment->comment, "\n";

モジュール実装部。Module::Pluggableな部分です。'Default'パーサーはスペース区切りのタブを解析するものを指定しています。

package Text::MetaComment;
use strict;
use warnings;
use Module::Pluggable require => 1;
use Text::MetaComment::Result;

BEGIN {
    foreach my $plugin ( __PACKAGE__->plugins ) {
        eval "CORE::require $plugin";
        warn if $@ && $@ !~ /^Can't locate /;
    }
}

sub new {
    bless {}, shift;
}

sub parse {
    my $self = shift;
    my $string = shift;
    my $parser = shift || 'Default';

    my $result;    # Text::MetaComment::Result
    $result = eval "Text::MetaComment::Plugin::$parser->parse( q($string) )";
    warn $@ if $@;

    return $result;
}

1;

スペース区切りのタグ＆コメントを解析するDefaultパーサー。

package Text::MetaComment::Plugin::Default;
use strict;
use warnings;

use Text::MetaComment::Result;

# Tag style:
# [tag1 tag2 tag3 ... TagN]Comment

sub new {
    bless {}, shift;
}

sub parse {
    my $self = shift;
    my $string = shift;

    my @tags;
    my $comment;

    if ( $string =~ m/^\[(.*?)\](.*)$/ ) {
        @tags = split / /, $1;
        $comment = $2;
    } else {
        @tags = ();
        $comment = $string;
    }

    return Text::MetaComment::Result->new({
                                           tags => \@tags,
                                           comment => $comment,
                                          });
}

1;

Hatenaパーサー。かぜふろさんのコードそのまま。

package Text::MetaComment::Plugin::Hatena;
use strict;
use warnings;

use Text::MetaComment::Result;

# Tag style:
# [tag1][tag2][tag3]...[TagN]Comment

sub new {
    bless {}, shift;
}

sub parse {
    my $self = shift;
    my $string = shift;

    my @tags;
    my $comment;

    while ( length $string && $string =~ m!^\s*\[([^\]]+)\]! ) {
        my $tag = $1;
        $string =~ s!^\s*\[([^\]]+)\]!!;
        next unless length $tag;
        push @tags, $tag;
    }
    $comment = $string;

    return Text::MetaComment::Result->new({
                                           tags => \@tags,
                                           comment => $comment,
                                          });
}

1;

Resultもそのままですけど一応載せておきます。

package Text::MetaComment::Result;
use strict;
use warnings;
use base qw(Class::Accessor::Fast);
__PACKAGE__->mk_ro_accessors(qw(tags comment));

sub tags {
    my $self = shift;
    return wantarray ? @{$self->{tags} || []} : $self->{tags};
}

sub uniq_tags {
    my $self = shift;
    my %seen;
    my @tags;
    @tags = grep {!$seen{$_}++} $self->tags;
    return wantarray ? @tags : \@tags;
}

1;

パーサープラグインで同じこと書いてる部分がある(DRY!)のでそこは基底クラスにまとめるべきですね。あと今見たらText::MetaComment::parse()の引数指定がハッシュじゃなくてダサいことに気がついた。気を抜いてるとCっぽくなってしまってます。あとできればパーサーも勝手に選択してほしいけど地道にやる方法しかすぐには思いつかないです。まぁそれは次の課題として(前２者はすぐ解決できる)。