Hackathon - つんでれ

Danさんがつんperlを実装してたので、さらに拡張してみた。まず、Acme::Compileというベースクラスで、

  package Acme::Compile::Tsundere;

  use strict;

  use base qw(Acme::Compile);


  ...

みたいにして拡張できるようにした。あとメッセージの変換はregister_pattern()というメソッドで逐次足せるようにしてみたぞ。これでつんでれメッセージも定義し放題だ！あとはメッセージのパターンを送ってくれ！w

# Copyright (c) 2006 Daisuke Maki <dmaki@cpan.org>
# All rights reserved.

package Acme::Compile;

use strict;

use base qw(Class::Data::Inheritable);

use Module::Compile -base;

BEGIN

{

    __PACKAGE__->mk_classdata('RegisteredPatterns');

    __PACKAGE__->RegisteredPatterns([]);

}

sub pmc_compile

{

    my ($class, $source) = @_;

    my $filename = $0;

    $source =~ s/no\s+$class\s*.*;\n//o;

    eval $source;

    return q() unless $@;

    my $e = $@;

    my $context = {

        class => $class,

        filename => $filename,

    };

    $class->pre_translate();

    foreach my $line (split (/\n/, $e)) {

        $class->translate($line, $context);

    }

    $class->post_translate();

    return q();

}

sub register_pattern

{

    my $class = shift;

    my %args  = @_;

    my $p = $class->RegisteredPatterns;

    push @$p, \%args;

}

sub pre_translate {}

sub post_translate {}

sub translate

{

    my $class   = shift;

    my $line    = shift;

    my $context = shift;

    my $patterns = $class->RegisteredPatterns;

    my @patterns = sort { rand > 0.5 } @$patterns;

    foreach my $data (@patterns) {

        my $pattern = $data->{pattern};

        my $replace = $data->{replace};

        last if $line =~ s{$pattern}{

            ref($replace) eq 'CODE' ? 

                $replace->($context) : $replace

        }ex;

    }

    print $line, "\n";

}

1;

と、Tsundereクラス

package Acme::Compile::Tsundere;

use strict;

use base qw(Acme::Compile);

    

BEGIN   

{   

    __PACKAGE__->register_pattern(

        pattern => qr{Global symbol "([^\"]+)" requires explicit package name at (?:.*?) line (\d+).},

        replace => sub {

            my $context = shift;

            qq(ちょっと!「$context->{filename}」の) .

            qq($3行目の「$1」には明示的なパッケージ名が必要なの!);

        },

    ); 


    __PACKAGE__->register_pattern(

        pattern => qr{Global symbol "([^\"]+)" requires explicit package name at (?:.*?) line (\d+).},

        replace => sub {

            my $context = shift;

            qq(もう～！いったい何回「$context->{filename}」の) .

            qq($3行目の「$1」は明示的なパッケージ名が必要だって言わせるの？);

        }

    ); 

}   

    

1;