Changeset 916

Show
Ignore:
Timestamp:
10/30/07 19:47:32 (7 years ago)
Author:
tokuhirom
Message:

lang/perl/mobirc: now text filter is pluggable(WARNINGS: INCOMPATIBLE CHANGE!!)

Location:
lang/perl/mobirc/trunk/mobirc
Files:
8 added
4 modified
1 moved

Legend:

Unmodified
Added
Removed
  • lang/perl/mobirc/trunk/mobirc/config.yaml.sample

    r883 r916  
    3434    #   config: 
    3535    #     au_subscriber_id: 25253252_oe.ezweb.ne.jp 
     36  filter: 
     37    - module: Mobirc::HTTPD::Filter::URL 
     38      config: 
     39        au_pcsv: 1 
     40        pocket_hatena: 1 
     41    - module: Mobirc::HTTPD::Filter::TelephoneNumber 
     42    - module: Mobirc::HTTPD::Filter::MailAddress 
     43    - module: Mobirc::HTTPD::Filter::DecorateIRCColor 
    3644  # charset: cp932 
    3745  # root: / 
    3846  # content_type: text/html; charset=Shift_JIS 
    39   # au_pcsv: 1 
    4047 
  • lang/perl/mobirc/trunk/mobirc/lib/Mobirc/ConfigLoader.pm

    r905 r916  
    5959                echo           => { type => 'bool', }, 
    6060                au_pcsv        => { type => 'bool', }, 
     61                filter => { 
     62                    type     => 'seq', 
     63                    sequence => [ 
     64                        { 
     65                            type    => 'map', 
     66                            mapping => { 
     67                                module => { type => 'str', required => 1, }, 
     68                                config => { type => 'any', }, 
     69                            }, 
     70                        }, 
     71                    ], 
     72                }, 
    6173                authorizer => { 
    6274                    type     => 'seq', 
  • lang/perl/mobirc/trunk/mobirc/lib/Mobirc/HTTPD/Controller.pm

    r905 r916  
    88use Template; 
    99use File::Spec; 
    10 use URI::Find; 
    1110use URI::Escape; 
    1211use HTTP::Response; 
     
    286285    $body = encode_entities($body, q(<>&"')); 
    287286 
    288     URI::Find->new( 
    289         sub { 
    290             my ( $uri, $orig_uri ) = @_; 
    291  
    292             my $out = qq{<a href="$uri" rel="nofollow">$orig_uri</a>}; 
    293             if ( $c->{config}->{httpd}->{au_pcsv} ) { 
    294                 $out .= 
    295                   sprintf( '<a href="device:pcsiteviewer?url=%s">[PCSV]</a>', 
    296                     $uri ); 
    297             } 
    298             $out .= 
    299               sprintf( 
    300 '<a href="http://mgw.hatena.ne.jp/?url=%s&noimage=0&split=1">[ph]</a>', 
    301                 uri_escape($uri) ); 
    302             return $out; 
    303         } 
    304     )->find( \$body ); 
    305  
    306     $body =~ 
    307 s!\b(0\d{1,3})([-(]?)(\d{2,4})([-)]?)(\d{4})\b!<a href="tel:$1$3$5">$1$2$3$4$5</a>!g; 
    308     $body =~ 
    309       s!\b(\w[\w.+=-]+\@[\w.-]+[\w]\.[\w]{2,4})\b!<a href="mailto:$1">$1</a>!g; 
    310  
    311     $body = decorate_irc_color($body); 
     287    DEBUG "APPLY FILTERS"; 
     288    for my $filter ( @{ $c->{config}->{httpd}->{filter} || [] } ) { 
     289        DEBUG "LOAD FILTER MODULE: $filter->{module}"; 
     290 
     291        $filter->{module}->use or die $@; 
     292        $body = $filter->{module}->process($body, $filter->{config}); 
     293    } 
    312294 
    313295    return $body; 
  • lang/perl/mobirc/trunk/mobirc/lib/Mobirc/Util.pm

    r908 r916  
    122122} 
    123123 
    124 sub decorate_irc_color { 
    125     my $src = shift; 
    126  
    127     if ($src !~ /[\x02\x03\x0f\x16\x1f]/) { 
    128         # skip without colorcode 
    129         return $src 
    130     } 
    131  
    132     my $colorized = ''; 
    133     my %default_state = ( 
    134         bold => 0, 
    135         inverse => 0, 
    136         underline => 0, 
    137        ); 
    138     my %state = (%default_state); 
    139     my $oldstyle = ''; 
    140     my $output_span = sub { 
    141         my $style = ''; 
    142         if ($state{bold}) { 
    143             $style .= "font-weight:bold;"; 
    144         } 
    145         if ($state{underline}) { 
    146             $style .= "text-decoration:underline;"; 
    147         } 
    148         if ($state{inverse}) { 
    149             # xxx not sure this is correct 
    150             @state{qw(color bgcolor)} = @state{qw(bgcolor color)}; 
    151             # XXX too bad 
    152             delete $state{inverse}; 
    153         } 
    154         if ($state{color}) { 
    155             if (my $color = irc_color($state{color})) { 
    156                 $style .= "color:$color;"; 
    157             } 
    158         } 
    159         if ($state{bgcolor}) { 
    160             if (my $color = irc_color($state{bgcolor})) { 
    161                 $style .= "background-color:$color;"; 
    162             } 
    163         } 
    164         my $output = ''; 
    165         if ($oldstyle ne $style) { 
    166             if ($oldstyle) { 
    167                 $output .= '</span>'; 
    168             } 
    169             if ($style) { 
    170                 $output .= qq{<span style="$style">} 
    171             } 
    172         } 
    173         $oldstyle = $style; 
    174         $output; 
    175     }; 
    176  
    177     while ($src) { 
    178         if ($src =~ s/^\x02//) { 
    179             $state{bold} = !$state{bold}; 
    180         } elsif ($src =~ s/^\x03(?:(\d{1,2})(?:,(\d{1,2}))?)?//) { 
    181             # if it has bad color specifiers, just ignore it. 
    182             $state{color} = int($1) if $1; 
    183             $state{bgcolor} = int($2) if $2; 
    184         } elsif ($src =~ s/^\x0f//) { 
    185             %state = (%default_state); 
    186         } elsif ($src =~ s/^\x16//) { 
    187             $state{inverse} = !$state{inverse}; 
    188         } elsif ($src =~ s/^\x1f//) { 
    189             $state{underline} = !$state{underline}; 
    190         } elsif ($src =~ s/^([^\x02\x03\x16\x1f\x0f]+)//) { 
    191             $colorized .= $output_span->() . $1; 
    192         } else { 
    193             if ($src =~ s/^(.*)$//) { 
    194                 # garbase 
    195                 use Data::Dumper; 
    196                 DEBUG "garbage: ".Dumper($1); 
    197                 $colorized .= $output_span->() . $1; 
    198             } 
    199             last; 
    200         } 
    201     } 
    202     %state = (%default_state); 
    203     $colorized .= $output_span->(); 
    204  
    205     return $colorized; 
    206 } 
    207  
    208 my %color_table; 
    209 BEGIN { %color_table = ( 
    210     0  => [qw(white)], 
    211     1  => [qw(black)], 
    212     2  => [qw(blue         navy)], 
    213     3  => [qw(green)], 
    214     4  => [qw(red)], 
    215     5  => [qw(brown        maroon)], 
    216     6  => [qw(purple)], 
    217     7  => [qw(orange       olive)], 
    218     8  => [qw(yellow)], 
    219     9  => [qw(lightgreen   lime)], 
    220     10 => [qw(teal)], 
    221     11 => [qw(lightcyan    cyan aqua)], 
    222     12 => [qw(lightblue    royal)], 
    223     13 => [qw(pink         lightpurple  fuchsia)], 
    224     14 => [qw(grey)], 
    225     15 => [qw(lightgrey    silver)], 
    226    ); 
    227 } 
    228  
    229 sub irc_color { 
    230     my $num = shift; 
    231     $color_table{$num}->[0]; 
    232 } 
    233  
    2341241; 
  • lang/perl/mobirc/trunk/mobirc/t/05-filter-decorate_irc_color.t

    r896 r916  
    22use warnings; 
    33use Data::Dumper; 
     4use Mobirc::HTTPD::Filter::DecorateIRCColor;; 
    45 
    56use Test::Base; 
    67eval q{ use String::IRC }; 
    78plan skip_all => "String::IRC is not installed." if $@; 
    8 use Mobirc::Util; 
    99 
    1010filters { 
    1111    input => ['eval', 'decorate_irc_color'], 
    1212}; 
     13 
     14sub decorate_irc_color { 
     15    my $x = shift; 
     16    Mobirc::HTTPD::Filter::DecorateIRCColor->process( $x, {} ); 
     17} 
    1318 
    1419run_is input => 'expected';