Changeset 768

Show
Ignore:
Timestamp:
10/28/07 01:37:36 (6 years ago)
Author:
tokuhirom
Message:

lang/perl/mobirc: split controller from httpd.

Location:
lang/perl/mobirc/trunk/mobirc
Files:
2 added
2 modified

Legend:

Unmodified
Added
Removed

  • lang/perl/mobirc/trunk/mobirc/lib/Mobirc/HTTPD.pm

    r765 r768  
    2020use Scalar::Util qw/blessed/; 
    2121 
    22 use Mobirc; 
    2322use Mobirc::Util; 
    24  
    25 # TODO: should be configurable? 
    26 use constant cookie_ttl => 86400 * 3;    # 3 days 
     23use Mobirc::HTTPD::Controller; 
    2724 
    2825our $GLOBAL_CONFIG;                      # TODO: should use HEAP. 
    … …  
    127124    } 
    128125 
    129     { 
    130         no strict 'refs'; ## no critic. 
    131         if ( $c->{req}->method =~ /POST/i && *{__PACKAGE__ . "::post_dispatch_$meth"}) { 
    132             return &{__PACKAGE__ . "::post_dispatch_$meth"}($c, @args); 
    133         } else { 
    134             return &{__PACKAGE__ . "::dispatch_$meth"}($c, @args); 
    135         } 
     126    if ( $c->{req}->method =~ /POST/i && Mobirc::HTTPD::Controller->can("post_dispatch_$meth")) { 
     127        return Mobirc::HTTPD::Controller->call("post_dispatch_$meth", $c, @args); 
     128    } else { 
     129        return Mobirc::HTTPD::Controller->call("dispatch_$meth", $c, @args); 
    136130    } 
    137131} 
    … …  
    162156} 
    163157 
    164 sub post_dispatch_show_channel { 
    165     my ( $c, $recent_mode, $channel) = @_; 
    166  
    167     my $r       = CGI->new( $c->{req}->content ); 
    168     my $message = $r->param('msg'); 
    169     $message = decode( $c->{config}->{httpd}->{charset}, $message ); 
    170  
    171     DEBUG "POST MESSAGE $message"; 
    172  
    173     if ($message) { 
    174         $c->{poe}->kernel->post( 'keitairc_irc', privmsg => $channel => $message ); 
    175  
    176         add_message( 
    177             $c->{poe}, 
    178             decode( $c->{config}->{irc}->{incode}, $channel ), 
    179             $c->{config}->{irc}->{nick}, $message 
    180         ); 
    181     } 
    182  
    183     my $response = HTTP::Response->new(302); 
    184     $response->push_header( 'Location' => $c->{req}->uri . '?time=' . time); # TODO: must be absoulute url. 
    185     return $response; 
    186 } 
    187  
    188 sub dispatch_index { 
    189     my $c = shift; 
    190  
    191     return render( 
    192         $c, 
    193         'index' => { 
    194             exists_recent_entries => ( 
    195                 grep( $c->{irc_heap}->{unread_lines}->{$_}, keys %{ $c->{irc_heap}->{unread_lines} } ) 
    196                 ? true 
    197                 : false 
    198             ), 
    199             canon_channels => [ 
    200                 reverse 
    201                   sort { 
    202                     $c->{irc_heap}->{channel_mtime}->{$a} <=> $c->{irc_heap}->{channel_mtime}->{$b} 
    203                   } 
    204                   keys %{ $c->{irc_heap}->{channel_name} } 
    205             ], 
    206         } 
    207     ); 
    208 } 
    209  
    210 # recent messages on every channel 
    211 sub dispatch_recent { 
    212     my $c = shift; 
    213  
    214     my $out = render( 
    215         $c, 
    216         'recent' => { 
    217         }, 
    218     ); 
    219  
    220     # reset counter. 
    221     for my $canon_channel ( sort keys %{ $c->{irc_heap}->{channel_name} } ) { 
    222         $c->{irc_heap}->{unread_lines}->{$canon_channel}   = 0; 
    223         $c->{irc_heap}->{channel_recent}->{$canon_channel} = ''; 
    224     } 
    225  
    226     return $out; 
    227 } 
    228  
    229 # topic on every channel 
    230 sub dispatch_topics { 
    231     my $c = shift; 
    232  
    233     return render( 
    234         $c, 
    235         'topics' => { 
    236         }, 
    237     ); 
    238 } 
    239  
    240 sub dispatch_show_channel { 
    241     my ($c, $recent_mode, $channel) = @_; 
    242  
    243     my $out = render( 
    244         $c, 
    245         'show_channel' => { 
    246             canon_channel  => canon_name($channel), 
    247             channel        => $channel, 
    248             subtitle       => compact_channel_name($channel), 
    249             recent_mode    => $recent_mode, 
    250         } 
    251     ); 
    252  
    253     { 
    254         my $canon_channel = canon_name($channel); 
    255  
    256         # clear unread counter 
    257         $c->{irc_heap}->{unread_lines}->{$canon_channel} = 0; 
    258  
    259         # clear recent messages buffer 
    260         $c->{irc_heap}->{channel_recent}->{$canon_channel} = ''; 
    261     } 
    262  
    263     return $out; 
    264 } 
    265  
    266 sub render { 
    267     my ( $c, $name, $args ) = @_; 
    268  
    269     croak "invalid args : $args" unless ref $args eq 'HASH'; 
    270  
    271     # set default vars 
    272     $args = { 
    273         compact_channel_name => \&compact_channel_name, 
    274         docroot              => $c->{config}->{httpd}->{root}, 
    275         render_list          => sub { render_list( $c, @_ ) }, 
    276         user_agent           => $c->{user_agent}, 
    277         title                => $c->{config}->{httpd}->{title}, 
    278         version              => $Mobirc::VERSION, 
    279  
    280         %{ $c->{irc_heap} }, 
    281  
    282         %$args, 
    283     }; 
    284  
    285     my $tt = Template->new( 
    286         ABSOLUTE => 1, 
    287         INCLUDE_PATH => 
    288           File::Spec->catfile( $c->{config}->{global}->{assets_dir}, 'tmpl', ) 
    289     ); 
    290     $tt->process( 
    291         File::Spec->catfile( 
    292             $c->{config}->{global}->{assets_dir}, 
    293             'tmpl', "$name.html" 
    294         ), 
    295         $args, 
    296         \my $out 
    297     ) or die $tt->error; 
    298  
    299     my $content = decode( 'utf8', $out ); 
    300     $content = encode($c->{config}->{httpd}->{charset}, $content); 
    301  
    302     my $response = HTTP::Response->new(200); 
    303     $response->push_header( 'Content-type', 'text/html; charset=Shift_JIS' ); # TODO: should be configurable 
    304     $response->push_header('Content-Length' => length($content) ); 
    305  
    306     if ( $c->{config}->{httpd}->{use_cookie} ) { 
    307         set_cookie( $c, $response ); 
    308     } 
    309  
    310     $response->content( $content ); 
    311     return $response; 
    312 } 
    313  
    314 sub set_cookie { 
    315     my $c        = shift; 
    316     my $response = shift; 
    317  
    318     my ( $sec, $min, $hour, $mday, $mon, $year, $wday ) = 
    319       localtime( time + cookie_ttl ); 
    320  
    321     my $expiration = sprintf( 
    322         '%.3s, %.2d-%.3s-%.4s %.2d:%.2d:%.2d', 
    323         qw(Sun Mon Tue Wed Thu Fri Sat) [$wday], 
    324         $mday, 
    325         qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec) [$mon], 
    326         $year + 1900, 
    327         $hour, 
    328         $min, 
    329         $sec 
    330     ); 
    331     $response->push_header( 
    332         'Set-Cookie', 
    333         sprintf( 
    334             "username=%s; expires=%s; \n", 
    335             $c->{config}->{httpd}->{username}, $expiration 
    336         ) 
    337     ); 
    338     $response->push_header( 
    339         'Set-Cookie', 
    340         sprintf( 
    341             "passwd=%s; expires=%s; \n", 
    342             $c->{config}->{httpd}->{password}, $expiration 
    343         ) 
    344     ); 
    345 } 
    346  
    347 sub render_list { 
    348     my $c   = shift; 
    349     my $src = shift; 
    350  
    351     croak "must be flagged utf8" unless Encode::is_utf8($src); 
    352  
    353     $src = join "\n", reverse split /\n/, $src; 
    354  
    355     $src = encode_entities($src); 
    356  
    357     URI::Find->new( 
    358         sub { 
    359             my ( $uri, $orig_uri ) = @_; 
    360  
    361             my $out = qq{<a href="$uri" rel="nofollow">$orig_uri</a>}; 
    362             if ( $c->{config}->{httpd}->{au_pcsv} ) { 
    363                 $out .= 
    364                   sprintf( '<a href="device:pcsiteviewer?url=%s">[PCSV]</a>', 
    365                     $uri ); 
    366             } 
    367             $out .= 
    368               sprintf( 
    369 '<a href="http://mgw.hatena.ne.jp/?url=%s&noimage=0&split=1">[ph]</a>', 
    370                 uri_escape($uri) ); 
    371             return $out; 
    372         } 
    373     )->find( \$src ); 
    374  
    375     $src =~ 
    376 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; 
    377     $src =~ 
    378       s!\b(\w[\w.+=-]+\@[\w.-]+[\w]\.[\w]{2,4})\b!<a href="mailto:$1">$1</a>!g; 
    379  
    380     $src =~ s!\n!<br />\n!g; 
    381  
    382     return $src; 
    383 } 
    384  
    3851581; 
    386159 

  • lang/perl/mobirc/trunk/mobirc/mobirc

    r762 r768  
    3838$config->{httpd}->{root} ||= '/'; 
    3939$config->{global}->{assets_dir} ||= File::Spec->catfile($FindBin::Bin, 'assets'); 
     40$config->{httpd}->{cookie_ttl} ||= 86400 * 3;    # 3 days 
    4041 
    4142# daemonize 
    … …  
    101102    new name. 
    102103    use YAML instead of AppConfig 
     104    dispatcher likes Sledge(HTTPD) 
    103105 
    104106=head1 TODO 
    105107 
    106     dispatcher likes Sledge(HTTPD) 
    107108    avoid warnings. 
    108109    use poe's heap instead of global variables ;-(