lib/Keitairc/IrcBuffer.pm

   1 # -*- mode: perl; coding: utf-8 -*-
   2 # Keitairc::IrcBuffer
   3 # $Id: IrcBuffer.pm,v 1.20 2008-08-06 06:56:49 morimoto Exp $
   4 # $Source: /home/ishikawa/work/keitairc/tmp/keitairc/lib/Keitairc/IrcBuffer.pm,v $
   5 #
   6 # Copyright (c) 2008 Jun Morimoto <morimoto@mrmt.net>
   7 # This program is covered by the GNU General Public License 2
   8
   9 package Keitairc::IrcBuffer;
  10 use Encode;
  11 use strict;
  12 use warnings;
  13 use Data::Dumper;
  14
  15 ################################################################
  16 sub new{
  17         my $proto = shift;
  18         my $arg = shift;
  19         my $me = {};
  20
  21         $me->{history} = $arg->{history};
  22
  23         # join しているchannelの名称を記録するハッシュ。
  24         # - cid および name2cid ハッシュに格納されている値は整数。
  25         # - cid2nameハッシュに格納されている文字列、および name2cid の
  26         #   ハッシュキーは iso-2022-jp (ないしはそのircチャネルで使われ
  27         #   ているcharset)のまま。これは歴史的理由でこうするしかない。
  28         $me->{cid2name} = {};
  29         $me->{name2cid} = {};
  30
  31         # join しているtopicの名称を記録するハッシュ
  32         # charset: perl internal
  33         $me->{topic} = {};
  34
  35         $me->{nicks} = {};
  36
  37         $me->{tbuffer} = {};    # time, ref to array
  38         $me->{nbuffer} = {};    # nick, ref to array
  39         $me->{mbuffer} = {};    # message, perl internal, ref to array
  40         $me->{rbuffer} = {};    # read flag, ref to array
  41
  42         # 各チャネルの最終発言時刻
  43         $me->{mtime} = {};
  44
  45         # timestamp of last posted message
  46         $me->{timestamp} = 0;
  47
  48         bless $me;
  49 }
  50
  51 ################################################################
  52 sub add_nick{
  53         my($me, $cid, $nick, $chop, $realname) = @_;
  54         $me->{nicks}->{$cid}->{$nick}->{realname} = $realname;
  55         $me->{nicks}->{$cid}->{$nick}->{chop} = $chop;
  56 }
  57
  58 ################################################################
  59 sub list_nick{
  60         my($me, $cid, $nick, $chop, $realname) = @_;
  61         keys %{$me->{nicks}->{$cid}};
  62 }
  63
  64 ################################################################
  65 sub remove_nick{
  66         my($me, $cid, $nick) = @_;
  67         delete $me->{nicks}->{$cid}->{$nick};
  68 }
  69
  70 ################################################################
  71 sub get_nick_realname{
  72         my($me, $cid, $nick) = @_;
  73         $me->{nicks}->{$cid}->{$nick}->{realname};
  74 }
  75
  76 ################################################################
  77 sub op_nick{
  78         my($me, $cid, $nick) = @_;
  79         if(defined $me->{nicks}->{$cid}){
  80                 if(defined $me->{nicks}->{$cid}->{$nick}){
  81                         $me->{nicks}->{$cid}->{$nick}->{chop} = 1;
  82                 }
  83         }
  84 }
  85
  86 ################################################################
  87 sub deop_nick{
  88         my($me, $cid, $nick) = @_;
  89         if(defined $me->{nicks}->{$cid}){
  90                 if(defined $me->{nicks}->{$cid}->{$nick}){
  91                         $me->{nicks}->{$cid}->{$nick}->{chop} = 0;
  92                 }
  93         }
  94 }
  95
  96 ################################################################
  97 sub get_nick_op{
  98         my($me, $cid, $nick) = @_;
  99         if(defined $me->{nicks}->{$cid}){
 100                 if(defined $me->{nicks}->{$cid}->{$nick}){
 101                         return $me->{nicks}->{$cid}->{$nick}->{chop};
 102                 }
 103         }
 104 }
 105
 106 ################################################################
 107 sub channels{
 108         my $me = shift;
 109         map {
 110                 $_
 111         }(sort
 112           {
 113                   $me->mtime($b) <=> $me->mtime($a)
 114           } keys %{$me->{cid2name}});
 115 }
 116
 117 ################################################################
 118 sub now{
 119         my ($sec, $min, $hour) = localtime(time);
 120         sprintf('%02d:%02d', $hour, $min);
 121 }
 122
 123 ################################################################
 124 # 引数の $name (チャネル名) は、生の iso-2022-jp のまま、ないしは irc
 125 # チャネルで扱われている charset のまま扱うこと。こういう慣習なので
 126 # しょうがない。
 127 sub name2cid{
 128         my($me, $name) = @_;
 129         $name =~ tr/A-Z[\\]^/a-z{|}~/;
 130
 131         unless(defined $me->{name2cid}->{$name}){
 132                 my $cid = (sort { $b - $a } (keys %{$me->{cid2name}}))[0];
 133                 $cid++;
 134                 $me->{cid2name}->{$cid} = $name;
 135                 $me->{name2cid}->{$name} = $cid;
 136         }
 137
 138         $me->{name2cid}->{$name};
 139 }
 140
 141 ################################################################
 142 sub cid2name{
 143         my($me, $cid) = @_;
 144         $me->{cid2name}->{$cid};
 145 }
 146
 147 ################################################################
 148 sub part{
 149         my($me, $cid) = @_;
 150         delete $me->{cid2name}->{$cid};
 151         delete $me->{name2cid}->{$cid};
 152         delete $me->{topic}->{$cid};
 153         delete $me->{nicks}->{$cid};
 154         delete $me->{tbuffer}->{$cid};
 155         delete $me->{nbuffer}->{$cid};
 156         delete $me->{mbuffer}->{$cid};
 157         delete $me->{rbuffer}->{$cid};
 158 }
 159
 160 ################################################################
 161 sub join{
 162         my ($me, $name) = @_;
 163         my $cid = $me->name2cid($name);
 164         $me->{cid2name}->{$cid} = $name;
 165 }
 166
 167 ################################################################
 168 sub mtime{
 169         my($me, $cid) = @_;
 170         $me->{mtime}->{$cid} || 0;
 171 }
 172
 173 ################################################################
 174 sub unread_lines{
 175         my($me, $cid) = @_;
 176         scalar grep(/0/, @{$me->{rbuffer}->{$cid}});
 177 }
 178
 179 ################################################################
 180 sub topic{
 181         my($me, $cid, $topic) = @_;
 182         if(defined $topic){
 183                 $me->{topic}->{$cid} = $topic;
 184         }
 185         $me->{topic}->{$cid};
 186 }
 187
 188 ################################################################
 189 sub buffer_ptr{
 190         my($me, $cid) = @_;
 191         ($me->{tbuffer}->{$cid}, $me->{nbuffer}->{$cid},
 192          $me->{mbuffer}->{$cid}, $me->{rbuffer}->{$cid});
 193 }
 194
 195 ################################################################
 196 # 引数の $msg の charset は perl internal
 197 # $channel は iso-2022-jp または irc channel specific
 198 sub add_message{
 199         my($me, $cid, $message, $who) = @_;
 200
 201         unless(defined $me->{tbuffer}->{$cid}){
 202                 $me->{tbuffer}->{$cid} = [];
 203         }
 204         unless(defined $me->{nbuffer}->{$cid}){
 205                 $me->{nbuffer}->{$cid} = [];
 206                 }
 207         unless(defined $me->{mbuffer}->{$cid}){
 208                 $me->{mbuffer}->{$cid} = [];
 209         }
 210         unless(defined $me->{rbuffer}->{$cid}){
 211                 $me->{rbuffer}->{$cid} = [];
 212         }
 213
 214         push @{$me->{tbuffer}->{$cid}}, now();
 215         push @{$me->{nbuffer}->{$cid}}, $who;
 216         push @{$me->{mbuffer}->{$cid}}, $message;
 217         push @{$me->{rbuffer}->{$cid}}, 0;
 218
 219         if(@{$me->{tbuffer}->{$cid}} > $me->{history}){
 220                 shift @{$me->{tbuffer}->{$cid}};
 221         }
 222         if(@{$me->{nbuffer}->{$cid}} > $me->{history}){
 223                 shift @{$me->{nbuffer}->{$cid}};
 224         }
 225         if(@{$me->{mbuffer}->{$cid}} > $me->{history}){
 226                 shift @{$me->{mbuffer}->{$cid}};
 227         }
 228         if(@{$me->{rbuffer}->{$cid}} > $me->{history}){
 229                 shift @{$me->{rbuffer}->{$cid}};
 230         }
 231
 232         if($me->{cid2name}->{$cid} eq '*console*') {
 233                 $me->{mtime}->{$cid} = -1;
 234         } else {
 235                 $me->{mtime}->{$cid} = time;
 236         }
 237 }
 238
 239 ################################################################
 240 # チャネル名称を短かくする
 241 # 返り値は Perl internal code
 242 sub compact_channel_name{
 243         my $me = shift;
 244         my $cid = shift;
 245         my $name = $me->cid2name($cid);
 246
 247         return undef unless defined $name;
 248
 249         # この後の置換処理は、チャネル名の文字列が実際に運用されている
 250         # charset で行う必要がある。日本語が用いられている従来の irc チャ
 251         # ネルであれば iso-2022-jp-1 だし、ないしは utf8 のまま。
 252         $name = Encode::decode($::cf->irc_charset(), $name);
 253
 254         # #name:*.jp を %name に
 255         if($name =~ s/:\*\.jp$//){
 256                 $name =~ s/^#/%/;
 257         }
 258
 259         # 末尾の単独の @ は取る (plumプラグインのmulticast.plm対策)
 260         # @ の後に空白が入ることもあるようだ。理由はわからない。
 261         $name =~ s/\@\s*$//;
 262         $name;
 263 }
 264
 265 ################################################################
 266 sub simple_escape{
 267         my $me = shift;
 268         local($_) = shift;
 269         if(defined $_){
 270                 s/&/&amp;/g;
 271                 s/>/&gt;/g;
 272                 s/</&lt;/g;
 273         }
 274         $_;
 275 }
 276
 277 ################################################################
 278 sub colorize{
 279         my $me = shift;
 280         local($_) = shift;
 281
 282         my %ct = (
 283                 1 => 'Black',
 284                 2 => '#000080', # Navy Blue
 285                 3 => 'Green',
 286                 4 => 'Red',
 287                 5 => 'Maroon',
 288                 6 => 'Purple',
 289                 7 => 'Olive',
 290                 8 => 'Yellow',
 291                 9 => '#32cd32', # Lime Green
 292                 10 => 'Teal',
 293                 11 => 'Aqua',
 294                 12 => '#4169e1', # Royal Blue
 295                 13 => '#ff69b4', # Hot Pink
 296                 14 => '#a9a9a9', # Dark Gray
 297                 15 => '#d3d3d3', # Light Gray
 298                 16 => 'White');
 299         my $colored = 0;
 300
 301         return undef unless defined $_;
 302
 303         do{
 304                 if($colored){
 305                         s|\x03(\d{1,2})|sprintf('</font><font color="%s">', $ct{0+$1})|e;
 306                         if(s|\x03|</font>|){
 307                                 $colored = 0;
 308                         }
 309                 }else{
 310                         if(s|\x03(\d{1,2})|sprintf('<font color="%s">', $ct{0+$1})|e){
 311                                 $colored = 1;
 312                         }
 313                 }
 314         }while(m|\x03\d{1,2}|);
 315
 316         if($colored){
 317                 $_ .= '</font>';
 318         }
 319
 320         $_;
 321 }
 322
 323 ################################################################
 324 # 同一秒間の連続発言を防ぐためのチェック。
 325 #
 326 # 前回 update_timestamp() が呼ばれた時刻と同じ時刻に
 327 # 再度 update_timestamp() が呼ばれたら 0 を返す。
 328 #
 329 # 前回 update_timestamp() が呼ばれた時刻と異なる時刻に
 330 # 再度 update_timestamp() が呼ばれたら 1 を返す。
 331 #
 332 sub update_timestamp{
 333         my $me = shift;
 334         my $time = shift;
 335
 336         if($me->{timestamp} != $time){
 337                 $me->{timestamp} = $time;
 338                 return 1;
 339         }
 340
 341         return 0;
 342 }
 343
 344 1;