├── Changes ├── Makefile.PL ├── README ├── cpanfile ├── demo └── demo.pl ├── doc └── Chinese.pod ├── lib └── Mojo │ └── IRC │ └── Server │ ├── Chinese.pm │ ├── Chinese.pod │ └── Chinese │ ├── Base.pm │ ├── Channel.pm │ ├── Object.pm │ └── User.pm └── t └── load_module.t /Changes: -------------------------------------------------------------------------------- 1 | 2018-06-29 Mojo::IRC::Server::Chinese v1.8.2 2 | 1）修复客户端修改昵称时，如果昵称包含空格等特殊字符导致异常的问题 3 | 2）修复服务器打印时间中的年份格式错误 4 | 3）增加 INVITE WHOIS 支持 5 | 4）用户登录成功后，支持输出MOTD信息 6 | 5）更新依赖关系，解决 IO::Socket::SSL 2.009+ required for TLS support 问题 7 | 8 | 9 | 2017-02-12 Mojo::IRC::Server::Chinese v1.8.1 10 | 1）新增频道bug修复 11 | 2）TLS加密支持 12 | 13 | 2017-02-11 Mojo::IRC::Server::Chinese v1.8.0 14 | 1）增加登录验证支持 15 | 16 | 2017-02-11 Mojo::IRC::Server::Chinese v1.7.9 17 | 1）修复demo例子中的错误 18 | 2）增加 user_registered/new_channel 事件 19 | 3）客户端登录成功后服务端返回信息完善 20 | 21 | 2016-05-09 Mojo::IRC::Server::Chinese v1.7.8 22 | 1）修复设置监听host地址不生效，始终是0.0.0.0的问题 23 | 2）文档完善 24 | 25 | 2015-12-01 Mojo::IRC::Server::Chinese v1.7.7 26 | 1）修复部分客户端消息\n分割（默认\r\n）导致无法正常登录的问题 27 | 28 | 2015-11-16 Mojo::IRC::Server::Chinese v1.7.6 29 | 1）修复增加多个相同昵称虚拟帐号会导致程序进行死循环的严重bug 30 | 31 | 2015-10-22 Mojo::IRC::Server::Chinese v1.7.5 32 | 1）修复pod文档仍然使用旧的命名空间的bug 33 | 34 | 2015-10-22 Mojo::IRC::Server::Chinese v1.7.4 35 | 1）Mojo::IRC::Server改名为Mojo::IRC::Server::Chinese 36 | 37 | 2015-10-21 Mojo::IRC::Server v1.7.3 38 | 1）客户端直接退出未发送QUIT指令的情况进行处理 39 | 2）增加AWAY命令支持 40 | 3）增加服务端反向PING客户端的机制，客户端如果不响应PONG，180s超时会被服务端关闭链接 41 | 4）修复客户端QUIT消息重复发送给其他客户端 导致其他客户端会把QUIT消息打印到server tab中的bug 42 | 5）修复昵称已经存在的情况下更换昵称缺无法正常登录的bug 43 | 44 | 2015-09-07 Mojo::IRC::Server v1.7.2 45 | 1）修复虚拟用户可能出现重复新增的bug 46 | 2）修复irc客户端修改昵称服务器响应消息重复的bug 感谢@pity的测试反馈 47 | 3）已经加入频道的客户端重复加入，消息不广播给其他客户端 48 | 4）修复 WHO 的处理错误 49 | 5）修复频道广播消息的bug 50 | 6）添加对未识别命令的响应 51 | 7）修复 TOPIC 和 MODE 处理存在的bug 52 | 53 | 2015-09-06 Mojo::IRC::Server v1.7.1 54 | 1）修复No such channel响应消息格式错误的bug 55 | 2）新增特性：当真实帐号抢占了虚拟帐号，真实帐号退出后 虚拟帐号会自动还原回来 56 | 3）修复无法退出频道的bug 57 | 4）修复user相同时没有把客户端链接关闭的bug 58 | 5）修复频道发送消息重复的bug 59 | 6）修复服务器频道消息转发给非频道内用户的bug 60 | 61 | 2015-09-03 Mojo::IRC::Server v1.7.0 62 | 1）版本重构，大量更新 63 | 2）为纪念中国反法西斯抗战70周年，特别设置版本号为1.7.0，感谢@wxg的支持 64 | 65 | 2015-08-29 Mojo::IRC::Server v1.0.4 66 | 1）大量bug修复和基础功能的完善 67 | 2）支持用户私信消息 68 | 3）增加虚拟用户支持 69 | 70 | 2015-08-29 Mojo::IRC::Server v1.0.3 71 | 1）修复bug 72 | 2）重新调整代码框架 73 | 74 | 2015-08-29 Mojo::IRC::Server v1.0.2 75 | 添加发布到cpan相关的支持文件 76 | 77 | 2015-08-29 Mojo::IRC::Server v1.0.1 78 | 基础稳定版本发布 79 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use 5.010001; 2 | use ExtUtils::MakeMaker "6.46"; 3 | # See lib/ExtUtils/MakeMaker.pm for details of how to influence 4 | # the contents of the Makefile that is written. 5 | WriteMakefile( 6 | NAME => 'Mojo::IRC::Server::Chinese', 7 | VERSION_FROM => 'lib/Mojo/IRC/Server/Chinese.pm', # finds $VERSION 8 | DISTNAME => 'Mojo-IRC-Server-Chinese', 9 | LICENSE => "perl", 10 | PREREQ_PM => { 11 | "Mojolicious" => '7.69', 12 | "Parse::IRC" => '1.20', 13 | "Encode::Locale" => '1.05', 14 | }, # e.g., Module::Name => 1.1 15 | dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, 16 | clean => { FILES => 'Mojo-IRC-Server-Chinese-* MANIFEST' }, 17 | META_MERGE => { 18 | 'meta-spec' => { version => 2 }, 19 | resources => { 20 | repository=>{ 21 | type => 'git', 22 | url => 'git://github.com/sjdy521/Mojo-IRC-Server-Chinese.git', 23 | web => 'https://github.com/sjdy521/Mojo-IRC-Server-Chinese', 24 | }, 25 | }, 26 | }, 27 | ($] >= 5.005 ? ## Add these new keywords supported since 5.005 28 | ( 29 | ABSTRACT => 'A Chinese IRC server base on Mojolicious', 30 | AUTHOR => 'sjdy521 ') : ()), 31 | ); 32 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Mojo-IRC-Server-Chinese v1.8.2 2 | ======================== 3 | 使用Perl语言编写的IRC服务端，基于Mojolicious的异步事件驱动，支持中文昵称和频道名称 4 | 5 | 运行效果 6 | [15/08/29 15:56:17] [debug] C[127.0.0.1:40918] 已连接 7 | [15/08/29 15:56:17] [debug] C[127.0.0.1:40918] NICK root 8 | [15/08/29 15:56:17] [info] [127.0.0.1:40918] 设置昵称为 [root] 9 | [15/08/29 15:56:17] [debug] C[127.0.0.1:40918] USER root 0 * :root 10 | [15/08/29 15:56:17] [debug] S[127.0.0.1:40918] :chinese-irc-server 001 root :欢迎 11 | [15/08/29 15:56:30] [debug] C[127.0.0.1:40918] NICK 测试 12 | [15/08/29 15:56:30] [debug] S[127.0.0.1:40918] :root!root@127.0.0.1 NICK :测试 13 | [15/08/29 15:56:30] [info] [root] 修改昵称为 [测试] 14 | [15/08/29 15:56:40] [debug] C[127.0.0.1:40918] JOIN #中国人 15 | [15/08/29 15:56:40] [debug] S[127.0.0.1:40918] :测试!root@127.0.0.1 JOIN :#中国人 16 | [15/08/29 15:56:40] [info] [测试] 加入频道 #中国人 17 | [15/08/29 15:56:42] [debug] C[127.0.0.1:40918] MODE #中国人 18 | [15/08/29 15:56:42] [debug] S[127.0.0.1:40918] :chinese-irc-server 324 测试 #中国人 :+ 19 | [15/08/29 15:56:52] [debug] C[127.0.0.1:40918] PRIVMSG #中国人 :中国人当然要用中文IRC！ 20 | [15/08/29 15:56:52] [info] [测试] 在频道 #中国人 说: 中国人当然要用中文IRC！ 21 | 22 | 安装步骤 23 | 24 | $ cpan -i App::cpanminus #安装cpanm工具 25 | $ cpanm -v Mojo::IRC::Server::Chinese #使用cpanm工具自带的cpanm命令来在线安装模块 26 | 27 | 版本更新记录 28 | 29 | 请参见 Changes 文件 30 | 31 | COPYRIGHT 和 LICENCE 32 | 33 | Copyright (C) 2014 by sjdy521 34 | 35 | This library is free software; you can redistribute it and/or modify 36 | it under the same terms as Perl itself, either Perl version 5.10.1 or, 37 | at your option, any later version of Perl 5 you may have available. 38 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | requires 'Compress::Raw::Zlib'; 2 | requires 'IO::Compress::Gzip'; 3 | requires 'Time::HiRes'; 4 | requires 'Time::Piece'; 5 | requires 'Time::Seconds'; 6 | requires 'Digest::SHA'; 7 | requires 'Digest::MD5'; 8 | requires 'Encode::Locale','1.05'; 9 | requires 'Parse::IRC','1.20'; 10 | requires 'IO::Socket::SSL', '>= 1.94'; 11 | requires 'Mojolicious','>= 7.69, < 7.80'; 12 | recommends 'Term::ANSIColor'; 13 | conflicts 'Mojolicious','>= 7.80'; 14 | -------------------------------------------------------------------------------- /demo/demo.pl: -------------------------------------------------------------------------------- 1 | use lib "../lib/"; 2 | use Mojo::IRC::Server::Chinese; 3 | my $server = Mojo::IRC::Server::Chinese->new( 4 | port => 6667, 5 | log_level => "debug", 6 | ); 7 | $server->run(); 8 | -------------------------------------------------------------------------------- /doc/Chinese.pod: -------------------------------------------------------------------------------- 1 | =pod 2 | 3 | =encoding utf8 4 | 5 | =head1 NAME 6 | 7 | Mojo::IRC::Server::Chinese - A Chinese IRC server base on Mojolicious 8 | 9 | =head1 SYNOPSIS 10 | 11 | use Mojo::IRC::Server::Chinese; 12 | my $server = Mojo::IRC::Server::Chinese->new( 13 | host => "0.0.0.0", 14 | port => 6667, 15 | log_level => "debug", 16 | ); 17 | $server->run(); 18 | 19 | #监听多个地址端口，使用listen参数 20 | my $server = Mojo::IRC::Server::Chinese->new( 21 | log_level => "debug", 22 | listen => [ 23 | {host=>"0.0.0.0",port=>6667}, 24 | {host=>"0.0.0.0",port=>6668}, 25 | ], 26 | ); 27 | $server->run(); 28 | 29 | #TLS加密支持 30 | my $server = Mojo::IRC::Server::Chinese->new( 31 | log_level => "debug", 32 | listen => [ 33 | {host=>"0.0.0.0",port=>6667}, 34 | {host=>"0.0.0.0",port=>6697,tls=>1}, 35 | ], 36 | ); 37 | $server->run(); 38 | 39 | #TLS更多详细参数使用说明参见 https://metacpan.org/pod/Mojo::IOLoop::Server#tls 40 | tls #0|1 是否启用tls加密 41 | tls_ca #可选，本地ca证书路径 例如 /etc/tls/ca.crt 42 | tls_cert #可选，服务器证书路径，默认会生成一个测试证书 43 | tls_ciphers #可选，加密套件，例如 AES128-GCM-SHA256:RC4:HIGH:!MD5:!aNULL:!EDH 44 | tls_key #可选，服务器证书key文件路径 45 | tls_verify #可选，验证模式 46 | tls_version #可选，协议版本，例如 TLSv1_2 47 | 48 | #登录验证支持 49 | my $server = Mojo::IRC::Server::Chinese->new( 50 | log_level => "debug", 51 | listen => [ 52 | {host=>"0.0.0.0",port=>6667}, 53 | {host=>"0.0.0.0",port=>6668}, 54 | ], 55 | auth => sub{ 56 | my($nick,$user,$pass) = @_; #传递给验证函数的三个参数依次是 irc客户端的NICK/USER/PASS 57 | if($nick eq '小灰'){#对于昵称"小灰"进行密码验证 58 | return 0 if not defined $pass; #没有设置密码，验证失败 59 | return 0 if $pass ne '123456'; #设置的密码不是 "123456" 验证失败 60 | return 1; #验证成功，允许正常登录 61 | } 62 | else{return 1;}#对其他登录昵称不进行验证，全部允许登录 63 | }, 64 | ); 65 | $server->run(); 66 | 67 | 68 | =head1 DESCRIPTION 69 | 70 | Mojo::IRC::Server::Chinese是一个基于Mojolicious框架的IRC服务器，采用异步事件驱动，纯中文支持（请使用UTF8编码） 71 | 72 | 支持使用中文昵称、中文频道名称，不限制昵称长度，让该死的只能使用英文字符见鬼去吧，目前只实现了聊天相关的常用功能 73 | 74 | =head1 SEE ALSO 75 | 76 | L 77 | 78 | L 79 | 80 | L 81 | 82 | =head1 AUTHOR 83 | 84 | sjdy521, Esjdy521@163.comE 85 | 86 | =head1 COPYRIGHT AND LICENSE 87 | 88 | Copyright (C) 2014 by sjdy521 89 | 90 | This library is free software; you can redistribute it and/or modify 91 | it under the same terms as Perl itself, either Perl version 5.10.1 or, 92 | at your option, any later version of Perl 5 you may have available. 93 | 94 | =cut 95 | -------------------------------------------------------------------------------- /lib/Mojo/IRC/Server/Chinese.pm: -------------------------------------------------------------------------------- 1 | package Mojo::IRC::Server::Chinese; 2 | use strict; 3 | $Mojo::IRC::Server::Chinese::VERSION = "1.8.2"; 4 | use Encode; 5 | use Encode::Locale; 6 | use Carp; 7 | use Parse::IRC; 8 | use Mojo::IOLoop; 9 | use POSIX (); 10 | use List::Util qw(first); 11 | use Fcntl ':flock'; 12 | use Mojo::IRC::Server::Chinese::Base 'Mojo::EventEmitter'; 13 | use Mojo::IRC::Server::Chinese::User; 14 | use Mojo::IRC::Server::Chinese::Channel; 15 | 16 | has host => "0.0.0.0"; 17 | has port => 6667; 18 | has listen => undef; 19 | has network => "Chinese IRC NetWork"; 20 | has ioloop => sub { Mojo::IOLoop->singleton }; 21 | has parser => sub { Parse::IRC->new }; 22 | has servername => "chinese-irc-server"; 23 | has clienthost => undef, 24 | has create_time => sub{POSIX::strftime( '%Y/%m/%d %H:%M:%S', localtime() )}; 25 | has log_level => "info"; 26 | has log_path => undef; 27 | has auth=>undef; 28 | has motd_path => undef; 29 | 30 | has version => sub{$Mojo::IRC::Server::Chinese::VERSION}; 31 | has start_time => sub{time}; 32 | 33 | has user => sub {[]}; 34 | has channel => sub {[]}; 35 | 36 | has log => sub{ 37 | require Mojo::Log; 38 | no warnings 'redefine'; 39 | *Mojo::Log::append = sub{ 40 | my ($self, $msg) = @_; 41 | return unless my $handle = $self->handle; 42 | flock $handle, LOCK_EX; 43 | $handle->print(encode("console_out", decode("utf8",$msg))) or $_[0]->die("Can't write to log: $!"); 44 | flock $handle, LOCK_UN; 45 | }; 46 | Mojo::Log->new(path=>$_[0]->log_path,level=>$_[0]->log_level,format=>sub{ 47 | my ($time, $level, @lines) = @_; 48 | my $title=""; 49 | if(ref $lines[0] eq "HASH"){ 50 | my $opt = shift @lines; 51 | $time = $opt->{"time"} if defined $opt->{"time"}; 52 | $title = (defined $opt->{"title"})?$opt->{title} . " ":""; 53 | $level = $opt->{level} if defined $opt->{"level"}; 54 | } 55 | @lines = split /\n/,join "",@lines; 56 | my $return = ""; 57 | $time = POSIX::strftime('[%y/%m/%d %H:%M:%S]',localtime($time)); 58 | for(@lines){ 59 | $return .= 60 | $time 61 | . " " 62 | . "[$level]" 63 | . " " 64 | . $title 65 | . $_ 66 | . "\n"; 67 | } 68 | return $return; 69 | }); 70 | }; 71 | 72 | sub new_user{ 73 | my $s = shift; 74 | my $user = $s->add_user(Mojo::IRC::Server::Chinese::User->new(@_,_server=>$s)); 75 | return $user if $user->is_virtual; 76 | $user->io->on(read=>sub{ 77 | my($stream,$bytes) = @_; 78 | $bytes = $user->buffer . $bytes; 79 | my $pos = rindex($bytes,"\r\n"); 80 | if($pos != -1){#\r\n 81 | my $lines = substr($bytes,0,$pos); 82 | my $remains = substr($bytes,$pos+2); 83 | $user->buffer($remains); 84 | $stream->emit(line=>$_) for split /\r?\n/,$lines; 85 | } 86 | else{ 87 | $pos = rindex($bytes,"\n"); 88 | if($pos != -1){ 89 | my $lines = substr($bytes,0,$pos); 90 | my $remains = substr($bytes,$pos+1); 91 | $user->buffer($remains); 92 | $stream->emit(line=>$_) for split /\r?\n/,$lines; 93 | } 94 | else{ 95 | $user->buffer($bytes); 96 | } 97 | } 98 | }); 99 | $user->io->on(line=>sub{ 100 | my($stream,$line) = @_; 101 | my $msg = $s->parser->parse($line); 102 | $user->last_active_time(time()); 103 | $s->emit(user_msg=>$user,$msg); 104 | if($msg->{command} eq "CAP"){$user->emit(cap=>$msg);$s->emit(cap=>$user,$msg);} 105 | elsif($msg->{command} eq "PASS"){$user->emit(pass=>$msg);$s->emit(pass=>$user,$msg);} 106 | elsif($msg->{command} eq "NICK"){$user->emit(nick=>$msg);$s->emit(nick=>$user,$msg);} 107 | elsif($msg->{command} eq "USER"){$user->emit(user=>$msg);$s->emit(user=>$user,$msg);} 108 | elsif($msg->{command} eq "JOIN"){$user->emit(join=>$msg);$s->emit(join=>$user,$msg);} 109 | elsif($msg->{command} eq "PART"){$user->emit(part=>$msg);$s->emit(part=>$user,$msg);} 110 | elsif($msg->{command} eq "KICK"){$user->emit(kick=>$msg);$s->emit(kick=>$user,$msg);} 111 | elsif($msg->{command} eq "INVITE"){$user->emit(invite=>$msg);$s->emit(invite=>$user,$msg);} 112 | elsif($msg->{command} eq "PING"){$user->emit(ping=>$msg);$s->emit(ping=>$user,$msg);} 113 | elsif($msg->{command} eq "PONG"){$user->emit(pong=>$msg);$s->emit(pong=>$user,$msg);} 114 | elsif($msg->{command} eq "MODE"){$user->emit(mode=>$msg);$s->emit(mode=>$user,$msg);} 115 | elsif($msg->{command} eq "PRIVMSG"){$user->emit(privmsg=>$msg);$s->emit(privmsg=>$user,$msg);} 116 | elsif($msg->{command} eq "QUIT"){$user->is_quit(1);$user->emit(quit=>$msg);$s->emit(quit=>$user,$msg);} 117 | elsif($msg->{command} eq "WHO"){$user->emit(who=>$msg);$s->emit(who=>$user,$msg);} 118 | elsif($msg->{command} eq "WHOIS"){$user->emit(whois=>$msg);$s->emit(whois=>$user,$msg);} 119 | elsif($msg->{command} eq "LIST"){$user->emit(list=>$msg);$s->emit(list=>$user,$msg);} 120 | elsif($msg->{command} eq "TOPIC"){$user->emit(topic=>$msg);$s->emit(topic=>$user,$msg);} 121 | elsif($msg->{command} eq "AWAY"){$user->emit(away=>$msg);$s->emit(away=>$user,$msg);} 122 | else{$user->send($user->serverident,"421",$user->nick,$msg->{command},"Unknown command");} 123 | }); 124 | 125 | $user->io->on(error=>sub{ 126 | my ($stream, $err) = @_; 127 | $user->emit("close",$err); 128 | $s->emit(close_user=>$user,$err); 129 | $s->debug("C[" .$user->name."] 连接错误: $err"); 130 | }); 131 | $user->io->on(close=>sub{ 132 | my ($stream, $err) = @_; 133 | $user->emit("close",$err); 134 | $s->emit(close_user=>$user,$err); 135 | }); 136 | $user->on(close=>sub{ 137 | my ($user,$err) = @_; 138 | return if $user->is_quit; 139 | my $quit_reason = defined $user->close_reason? $user->close_reason: 140 | defined $err ? $err : 141 | "remote host closed connection"; 142 | $user->forward($user->ident,"QUIT",$quit_reason); 143 | $user->is_quit(1); 144 | $user->info("[" . $user->name . "] 已退出($quit_reason)"); 145 | $user->{_server}->remove_user($user); 146 | }); 147 | $user->on(pass=>sub{my($user,$msg) = @_;my $pass = $msg->{params}[0]; $user->pass($pass);}); 148 | $user->on(nick=>sub{my($user,$msg) = @_;my $nick = $msg->{params}[0];$user->set_nick($nick)}); 149 | $user->on(user=>sub{my($user,$msg) = @_; 150 | if(defined $user->search_user(user=>$msg->{params}[0])){ 151 | $user->send($user->serverident,"446",$user->nick,"该帐号已被使用"); 152 | $user->io->close_gracefully(); 153 | $user->{_server}->remove_user($user); 154 | return; 155 | } 156 | $user->user($msg->{params}[0]); 157 | #$user->mode($msg->{params}[1]); 158 | $user->realname($msg->{params}[3]); 159 | if(!$user->is_registered and $user->nick ne "*" and $user->user ne "*"){ 160 | $user->is_registered(1); 161 | } 162 | }); 163 | $user->on(join=>sub{my($user,$msg) = @_; 164 | my $channels = $msg->{params}[0]; 165 | for my $channel_name (split /,/,$channels){ 166 | my $channel = $user->search_channel(name=>$channel_name); 167 | if(defined $channel){ 168 | $user->join_channel($channel); 169 | } 170 | else{ 171 | $channel = $user->new_channel(name=>$channel_name,id=>lc($channel_name)); 172 | $user->join_channel($channel); 173 | } 174 | } 175 | }); 176 | $user->on(part=>sub{my($user,$msg) = @_; 177 | my $channel_name = $msg->{params}[0]; 178 | my $part_info = $msg->{params}[1]; 179 | my $channel = $user->search_channel(name=>$channel_name); 180 | return if not defined $channel; 181 | $user->part_channel($channel,$part_info); 182 | }); 183 | $user->on(invite=>sub{ 184 | my($user,$msg) = @_; 185 | my $invite_nickname = $msg->{params}[0]; 186 | my $channel_name = $msg->{params}[1]; 187 | my $channel = $user->search_channel(name=>$channel_name); 188 | my $invite_user = $user->search_user(nick=>$invite_nickname); 189 | if(not defined $invite_user){ 190 | $user->send($user->serverident,"401",$user->nick,$invite_nickname,"No such nick"); 191 | return; 192 | } 193 | if(not defined $channel){ 194 | $user->send($user->serverident,"403",$user->nick,$channel_name,"No such channel"); 195 | } 196 | elsif(defined $channel){ 197 | if( not $user->is_join_channel($channel)){ 198 | $user->send($user->serverident,"442",$user->nick,$channel->name,"You're not on that channel"); 199 | } 200 | elsif($invite_user->is_join_channel($channel)){ 201 | $user->send($user->serverident,"443",$user->nick,$invite_user->nick,$channel->name,"is already on channel"); 202 | } 203 | else{ 204 | $user->send($user->serverident,"341",$user->nick,$invite_user->nick,$channel->name); 205 | $invite_user->send($user->ident,"INVITE",$invite_user->nick,$channel->name); 206 | } 207 | } 208 | }); 209 | $user->on(ping=>sub{my($user,$msg) = @_; 210 | my $servername = $msg->{params}[0]; 211 | $user->send($user->serverident,"PONG",$user->servername,$servername); 212 | }); 213 | $user->on(pong=>sub{ 214 | my($user,$msg) = @_; 215 | my $current_ping_count = $user->ping_count; 216 | $user->ping_count(--$current_ping_count); 217 | }); 218 | $user->on(quit=>sub{my($user,$msg) = @_; 219 | my $quit_reason = $msg->{params}[0]; 220 | $user->quit($quit_reason); 221 | }); 222 | $user->on(privmsg=>sub{my($user,$msg) = @_; 223 | $user->last_speak_time(time()); 224 | if(substr($msg->{params}[0],0,1) eq "#" ){ 225 | my $channel_name = $msg->{params}[0]; 226 | my $content = $msg->{params}[1]; 227 | my $channel = $user->search_channel(name=>$channel_name); 228 | if(not defined $channel){$user->send($user->serverident,"403",$user->nick,$channel_name,"No such channel");return} 229 | $channel->forward($user,$user->ident,"PRIVMSG",$channel_name,$content); 230 | $s->info({level=>"IRC频道消息",title=>$user->nick ."|" .$channel->name.":"},$content); 231 | } 232 | else{ 233 | my $nick = $msg->{params}[0]; 234 | my $content = $msg->{params}[1]; 235 | my $u = $user->search_user(nick=>$nick); 236 | if(defined $u){ 237 | $u->send($user->ident,"PRIVMSG",$nick,$content); 238 | $user->send($user->serverident,"301",$user->nick,$u->nick,$u->away_info) if $u->is_away; 239 | $s->info({level=>"IRC私信消息",title=>"[".$user->nick."]->[$nick] :"},$content); 240 | } 241 | else{ 242 | $user->send($user->serverident,"401",$user->nick,$nick,"No such nick"); 243 | } 244 | } 245 | }); 246 | $user->on(mode=>sub{my($user,$msg) = @_; 247 | if(substr($msg->{params}[0],0,1) eq "#" ){ 248 | my $channel_name = $msg->{params}[0]; 249 | my $channel_mode = $msg->{params}[1]; 250 | my $channel = $user->search_channel(name=>$channel_name); 251 | if(not defined $channel){$user->send($user->serverident,"403",$user->nick,$channel_name,"No such channel");return} 252 | if(defined $channel_mode and $channel_mode eq "b"){ 253 | $user->send($user->serverident,"368",$user->nick,$channel_name,"End of channel ban list"); 254 | } 255 | elsif(defined $channel_mode and $channel_mode ne "b") { 256 | $channel->set_mode($user,$channel_mode); 257 | } 258 | else{ 259 | $user->send($user->serverident,"324",$user->nick,$channel_name,'+'.$channel->mode); 260 | $user->send($user->serverident,"329",$user->nick,$channel_name,$channel->ctime); 261 | } 262 | } 263 | else{ 264 | my $nick = $msg->{params}[0]; 265 | my $mode = $msg->{params}[1]; 266 | if(defined $mode){$user->set_mode($mode)} 267 | else{$user->send($user->serverident,"221",$user->nick,'+'.$user->mode)} 268 | } 269 | }); 270 | $user->on(who=>sub{my($user,$msg) = @_; 271 | if(substr($msg->{params}[0],0,1) eq "#" ){ 272 | my $channel_name = $msg->{params}[0]; 273 | my $channel = $user->search_channel(name=>$channel_name); 274 | if(not defined $channel){$user->send($user->serverident,"403",$user->nick,$channel_name,"No such channel");return} 275 | for($channel->users){ 276 | $user->send($user->serverident,"352",$user->nick,$channel_name,$_->user,$_->host,$_->servername,$_->nick,"H","0 " . $_->realname); 277 | } 278 | $user->send($user->serverident,"315",$user->nick,$channel_name,"End of WHO list"); 279 | } 280 | else{ 281 | my $nick = $msg->{params}[0]; 282 | my $u = $user->search_user(nick=>$nick); 283 | if(defined $u){ 284 | my $channel_name = "*"; 285 | if($u->is_join_channel()){ 286 | my $last_channel = (grep {$_->mode !~ /s/} $u->channels)[-1]; 287 | $channel_name = $last_channel->name if defined $last_channel; 288 | } 289 | $user->send($user->serverident,"352",$user->nick,$channel_name,$u->user,$u->host,$u->servername,$u->nick,"H","0 " . $u->realname); 290 | $user->send($user->serverident,"315",$user->nick,$nick,"End of WHO list"); 291 | } 292 | else{ 293 | $user->send($user->serverident,"401",$user->nick,$nick,"No such nick"); 294 | } 295 | 296 | } 297 | }); 298 | $user->on(whois=>sub{my($user,$msg) = @_; 299 | my $nickname = $msg->{params}[0]; 300 | my $whois_user = $user->search_user(nick=>$nickname); 301 | if(not defined $whois_user){ 302 | $user->send($user->serverident,"401",$user->nick,$nickname,"No such nick"); 303 | return; 304 | } 305 | $user->send($user->serverident,"311",$user->nick,$whois_user->nick,$whois_user->user,$whois_user->host,"*",$whois_user->realname); 306 | $user->send($user->serverident,"312",$user->nick,$whois_user->nick,$whois_user->servername,$whois_user->servername); 307 | $user->send($user->serverident,"319",$user->nick,$whois_user->nick,join(" ",map {$_->name} $whois_user->channels)); 308 | $user->send($user->serverident,"318",$user->nick,$whois_user->nick,"End of WHOIS list"); 309 | 310 | }); 311 | $user->on(list=>sub{my($user,$msg) = @_; 312 | for my $channel ($user->{_server}->channels){ 313 | next if $channel->mode =~ /s/; 314 | $user->send($user->serverident,"322",$user->nick,$channel->name,$channel->count(),$channel->topic); 315 | } 316 | $user->send($user->serverident,"323",$user->nick,"End of LIST"); 317 | }); 318 | $user->on(topic=>sub{my($user,$msg) = @_; 319 | my $channel_name = $msg->{params}[0]; 320 | my $channel = $user->search_channel(name=>$channel_name); 321 | if(not defined $channel){$user->send($user->serverident,"403",$user->nick,$channel_name,"No such channel");return} 322 | if(defined $msg->{params}[1]){ 323 | my $topic = $msg->{params}[1]; 324 | $channel->set_topic($user,$topic); 325 | } 326 | else{ 327 | $user->send($user->serverident,"332",$user->nick,$channel_name,$channel->topic); 328 | } 329 | }); 330 | $user->on(away=>sub{my($user,$msg) = @_; 331 | if($msg->{params}[0]){ 332 | my $away_info = $msg->{params}[0]; 333 | $user->away($away_info); 334 | } 335 | else{ 336 | $user->back(); 337 | } 338 | }); 339 | 340 | $user; 341 | } 342 | sub new_channel{ 343 | my $s = shift; 344 | my $channel = $s->add_channel(Mojo::IRC::Server::Chinese::Channel->new(@_,_server=>$s)); 345 | $s->emit(new_channel=>$channel); 346 | return $channel; 347 | } 348 | sub add_channel{ 349 | my $s = shift; 350 | my $channel = shift; 351 | my $is_cover = shift; 352 | my $channel_name = $channel->name; 353 | $channel_name = "#" . $channel_name if substr($channel_name,0,1) ne "#"; 354 | $channel_name=~s/\s|,|&//g; 355 | $channel->name($channel_name); 356 | my $c = $s->search_channel(name=>$channel->name); 357 | return $c if defined $c; 358 | $c = $s->search_channel(id=>$channel->id); 359 | if(defined $c){if($is_cover){$s->info("频道 " . $c->name. " 已更新");$c=$channel;};return $c;} 360 | else{push @{$s->channel},$channel;$s->info("频道 ".$channel->name. " 已创建");return $channel;} 361 | 362 | } 363 | sub add_user{ 364 | my $s = shift; 365 | my $user = shift; 366 | my $is_cover = shift; 367 | if($user->is_virtual){ 368 | my $nick = $user->nick; 369 | $nick =~s/\s|\@|!//g;$nick = '未知昵称' if not $nick; 370 | $user->nick($nick); 371 | my $u = $s->search_user(nick=>$user->nick,virtual=>1,id=>$user->id); 372 | return $u if defined $u; 373 | while(1){ 374 | my $u = $s->search_user(nick=>$user->nick); 375 | if(defined $u){ 376 | if($u->nick =~/\((\d+)\)$/){ 377 | my $num = $1;$num++;$user->nick($nick . "($num)"); 378 | } 379 | else{$user->nick($nick . "(1)")} 380 | } 381 | else{last}; 382 | } 383 | } 384 | my $u = $s->search_user(id=>$user->id); 385 | if(defined $u){if($is_cover){$s->info("C[".$u->name. "]已更新");$u=$user;};return $u;} 386 | else{ 387 | push @{$s->user},$user;$s->info("C[".$user->name. "]已加入");return $user; 388 | } 389 | } 390 | sub remove_user{ 391 | my $s = shift; 392 | my $user = shift; 393 | for(my $i=0;$i<@{$s->user};$i++){ 394 | if($user->id eq $s->user->[$i]->id){ 395 | $_->remove_user($s->user->[$i]->id) for $s->user->[$i]->channels; 396 | $user->channel([]); 397 | splice @{$s->user},$i,1; 398 | if($user->is_virtual){ 399 | $s->info("c[".$user->name."] 已被移除"); 400 | } 401 | else{ 402 | $s->info("C[".$user->name."] 已离开"); 403 | } 404 | last; 405 | } 406 | } 407 | } 408 | 409 | sub remove_channel{ 410 | my $s = shift; 411 | my $channel = shift; 412 | for(my $i=0;$i<@{$s->channel};$i++){ 413 | if($channel->id eq $s->channel->[$i]->id){ 414 | splice @{$s->channel},$i,1; 415 | $s->info("频道 ".$channel->name." 已删除"); 416 | last; 417 | } 418 | } 419 | } 420 | sub users { 421 | my $s = shift; 422 | return @{$s->user}; 423 | } 424 | sub channels{ 425 | my $s = shift; 426 | return @{$s->channel}; 427 | } 428 | 429 | sub search_user{ 430 | my $s = shift; 431 | my %p = @_; 432 | return if 0 == grep {defined $p{$_}} keys %p; 433 | if(wantarray){ 434 | return grep {my $c = $_;(first {$p{$_} ne $c->$_} grep {defined $p{$_}} keys %p) ? 0 : 1;} @{$s->user}; 435 | } 436 | else{ 437 | return first {my $c = $_;(first {$p{$_} ne $c->$_} grep {defined $p{$_}} keys %p) ? 0 : 1;} @{$s->user}; 438 | } 439 | 440 | } 441 | sub search_channel{ 442 | my $s = shift; 443 | my %p = @_; 444 | return if 0 == grep {defined $p{$_}} keys %p; 445 | if(wantarray){ 446 | return grep {my $c = $_;(first {$_ eq "name"?(lc($p{$_}) ne lc($c->$_)):($p{$_} ne $c->$_)} grep {defined $p{$_}} keys %p) ? 0 : 1;} @{$s->channel}; 447 | } 448 | else{ 449 | return first {my $c = $_;(first {$_ eq "name"?(lc($p{$_}) ne lc($c->$_)):($p{$_} ne $c->$_)} grep {defined $p{$_}} keys %p) ? 0 : 1;} @{$s->channel}; 450 | } 451 | 452 | } 453 | sub timer{ 454 | my $s = shift; 455 | $s->ioloop->timer(@_); 456 | } 457 | sub interval{ 458 | my $s = shift; 459 | $s->ioloop->recurring(@_); 460 | } 461 | sub ident { 462 | return $_[0]->servername; 463 | } 464 | sub ready { 465 | my $s = shift; 466 | my @listen = (); 467 | if(defined $s->listen and ref $s->listen eq "ARRAY"){ 468 | for (@{$s->listen}){ 469 | $_->{address} = (delete $_->{host}) // "0.0.0.0"; 470 | $_->{port} = ($_->{tls} ? 6697: 6667) if not defined $_->{port}; 471 | push @listen,$_; 472 | } 473 | } 474 | else{ 475 | @listen = ({host=>$s->host,port=>$s->port}); 476 | } 477 | for my $listen (@listen){ 478 | $s->ioloop->server($listen=>sub{ 479 | my ($loop, $stream) = @_; 480 | $stream->timeout(0); 481 | my $id = join ":",( 482 | $stream->handle->sockhost, 483 | $stream->handle->sockport, 484 | $stream->handle->peerhost, 485 | $stream->handle->peerport 486 | ); 487 | my $user = $s->new_user( 488 | id => $id, 489 | name => join(":",($stream->handle->peerhost,$stream->handle->peerport)), 490 | io => $stream, 491 | ); 492 | $user->host($s->clienthost) if defined $s->clienthost; 493 | $s->emit(new_user=>$user); 494 | }); 495 | } 496 | 497 | $s->on(new_user=>sub{ 498 | my ($s,$user)=@_; 499 | $s->debug("C[".$user->name. "]已连接"); 500 | }); 501 | 502 | $s->on(user_registered=>sub{ 503 | my($s,$user) = @_; 504 | if(defined $s->auth and ref $s->auth eq "CODE"){ 505 | if(! $s->auth->($user->nick,$user->user,$user->pass)){ 506 | $user->send($user->serverident,"464",$user->nick,"认证失败"); 507 | $user->io->close_gracefully(); 508 | $user->{_server}->remove_user($user); 509 | return; 510 | } 511 | } 512 | $user->send($user->serverident,"001",$user->nick,"Welcome to " . $s->network . " " . $user->ident); 513 | $user->send($user->serverident,"002",$user->nick,"Your host is " . $s->servername. ", running version " . $s->version); 514 | $user->send($user->serverident,"003",$user->nick,"This server was created " . POSIX::strftime('%a %b %d %Y at %H:%M:%S %Z',localtime($s->start_time))); 515 | $user->send($user->serverident,"004",$user->nick,$s->servername." " .$s->version . " aio PioOvstkb"); 516 | $user->send($user->serverident,"251",$user->nick,"There are ". (0+@{$s->user}) ." users and 0 services on 1 servers"); 517 | if(defined $s->motd_path and -f $s->motd_path and -s $s->motd_path){ 518 | eval{ 519 | open my $motd_fd,$s->motd_path or die "open motd file [" . $s->motd_path . "] error: $!"; 520 | $user->send($user->serverident,"375",$user->nick,"- " . $s->servername . " Message of the day - "); 521 | while(<$motd_fd>){ 522 | s/[\r\n]+$//g; 523 | $user->send($user->serverident,"372",$user->nick,"- $_"); 524 | } 525 | $user->send($user->serverident,"376",$user->nick,"End of MOTD command"); 526 | }; 527 | $s->warn($@) if $@; 528 | } 529 | $user->send($user->serverident,"396",$user->nick,$user->host,"您的主机地址已被隐藏"); 530 | }); 531 | $s->on(user_msg=>sub{ 532 | my ($s,$user,$msg)=@_; 533 | $s->debug("C[".$user->name."] $msg->{raw_line}"); 534 | }); 535 | 536 | $s->on(close_user=>sub{ 537 | my ($s,$user,$msg)=@_; 538 | }); 539 | 540 | $s->interval(60,sub{ 541 | for(grep {defined $_->last_active_time and time() - $_->last_active_time > 60 } grep {!$_->is_virtual} $s->users){ 542 | if($_->ping_count >=3 ){ 543 | $_->close_reason("PING timeout 180 seconds"); 544 | $_->io->close_gracefully(); 545 | } 546 | else{ 547 | $_->send(undef,"PING",$_->servername); 548 | my $current_ping_count = $_->ping_count; 549 | $_->ping_count(++$current_ping_count); 550 | } 551 | } 552 | }); 553 | } 554 | 555 | sub run{ 556 | my $s = shift; 557 | $s->ready(); 558 | $s->ioloop->start unless $s->ioloop->is_running; 559 | } 560 | sub die{ 561 | my $s = shift; 562 | local $SIG{__DIE__} = sub{$s->log->fatal(@_);exit -1}; 563 | Carp::confess(@_); 564 | } 565 | sub info{ 566 | my $s = shift; 567 | $s->log->info(@_); 568 | $s; 569 | } 570 | sub warn{ 571 | my $s = shift; 572 | $s->log->warn(@_); 573 | $s; 574 | } 575 | sub error{ 576 | my $s = shift; 577 | $s->log->error(@_); 578 | $s; 579 | } 580 | sub fatal{ 581 | my $s = shift; 582 | $s->log->fatal(@_); 583 | $s; 584 | } 585 | sub debug{ 586 | my $s = shift; 587 | $s->log->debug(@_); 588 | $s; 589 | } 590 | 591 | 592 | 1; 593 | -------------------------------------------------------------------------------- /lib/Mojo/IRC/Server/Chinese.pod: -------------------------------------------------------------------------------- 1 | =pod 2 | 3 | =encoding utf8 4 | 5 | =head1 NAME 6 | 7 | Mojo::IRC::Server::Chinese - A Chinese IRC server base on Mojolicious 8 | 9 | =head1 SYNOPSIS 10 | 11 | use Mojo::IRC::Server::Chinese; 12 | my $server = Mojo::IRC::Server::Chinese->new( 13 | host => "0.0.0.0", 14 | port => 6667, 15 | log_level => "debug", 16 | ); 17 | $server->run(); 18 | 19 | #监听多个地址端口，使用listen参数 20 | my $server = Mojo::IRC::Server::Chinese->new( 21 | log_level => "debug", 22 | listen => [ 23 | {host=>"0.0.0.0",port=>6667}, 24 | {host=>"0.0.0.0",port=>6668}, 25 | ], 26 | ); 27 | $server->run(); 28 | 29 | #TLS加密支持 30 | my $server = Mojo::IRC::Server::Chinese->new( 31 | log_level => "debug", 32 | listen => [ 33 | {host=>"0.0.0.0",port=>6667}, 34 | {host=>"0.0.0.0",port=>6697,tls=>1}, 35 | ], 36 | ); 37 | $server->run(); 38 | 39 | #TLS更多详细参数使用说明参见 https://metacpan.org/pod/Mojo::IOLoop::Server#tls 40 | tls #0|1 是否启用tls加密 41 | tls_ca #可选，本地ca证书路径 例如 /etc/tls/ca.crt 42 | tls_cert #可选，服务器证书路径，默认会生成一个测试证书 43 | tls_ciphers #可选，加密套件，例如 AES128-GCM-SHA256:RC4:HIGH:!MD5:!aNULL:!EDH 44 | tls_key #可选，服务器证书key文件路径 45 | tls_verify #可选，验证模式 46 | tls_version #可选，协议版本，例如 TLSv1_2 47 | 48 | #登录验证支持 49 | my $server = Mojo::IRC::Server::Chinese->new( 50 | log_level => "debug", 51 | listen => [ 52 | {host=>"0.0.0.0",port=>6667}, 53 | {host=>"0.0.0.0",port=>6668}, 54 | ], 55 | auth => sub{ 56 | my($nick,$user,$pass) = @_; #传递给验证函数的三个参数依次是 irc客户端的NICK/USER/PASS 57 | if($nick eq '小灰'){#对于昵称"小灰"进行密码验证 58 | return 0 if not defined $pass; #没有设置密码，验证失败 59 | return 0 if $pass ne '123456'; #设置的密码不是 "123456" 验证失败 60 | return 1; #验证成功，允许正常登录 61 | } 62 | else{return 1;}#对其他登录昵称不进行验证，全部允许登录 63 | }, 64 | ); 65 | $server->run(); 66 | 67 | 68 | =head1 DESCRIPTION 69 | 70 | Mojo::IRC::Server::Chinese是一个基于Mojolicious框架的IRC服务器，采用异步事件驱动，纯中文支持（请使用UTF8编码） 71 | 72 | 支持使用中文昵称、中文频道名称，不限制昵称长度，让该死的只能使用英文字符见鬼去吧，目前只实现了聊天相关的常用功能 73 | 74 | =head1 SEE ALSO 75 | 76 | L 77 | 78 | L 79 | 80 | L 81 | 82 | =head1 AUTHOR 83 | 84 | sjdy521, Esjdy521@163.comE 85 | 86 | =head1 COPYRIGHT AND LICENSE 87 | 88 | Copyright (C) 2014 by sjdy521 89 | 90 | This library is free software; you can redistribute it and/or modify 91 | it under the same terms as Perl itself, either Perl version 5.10.1 or, 92 | at your option, any later version of Perl 5 you may have available. 93 | 94 | =cut 95 | -------------------------------------------------------------------------------- /lib/Mojo/IRC/Server/Chinese/Base.pm: -------------------------------------------------------------------------------- 1 | package Mojo::IRC::Server::Chinese::Base; 2 | use strict; 3 | use warnings; 4 | use feature (); 5 | 6 | # No imports because we get subclassed, a lot! 7 | use Carp (); 8 | 9 | # Only Perl 5.14+ requires it on demand 10 | use IO::Handle (); 11 | 12 | # Supported on Perl 5.22+ 13 | my $NAME 14 | = eval { require Sub::Util; Sub::Util->can('set_subname') } || sub { $_[1] }; 15 | 16 | # Protect subclasses using AUTOLOAD 17 | sub DESTROY { } 18 | 19 | # Declared here to avoid circular require problems in Mojo::Util 20 | sub _monkey_patch { 21 | my ($class, %patch) = @_; 22 | no strict 'refs'; 23 | no warnings 'redefine'; 24 | *{"${class}::$_"} = $NAME->("${class}::$_", $patch{$_}) for keys %patch; 25 | } 26 | 27 | sub attr { 28 | my ($self, $attrs, $value) = @_; 29 | return unless (my $class = ref $self || $self) && $attrs; 30 | 31 | Carp::croak 'Default has to be a code reference or constant value' 32 | if ref $value && ref $value ne 'CODE'; 33 | 34 | for my $attr (@{ref $attrs eq 'ARRAY' ? $attrs : [$attrs]}) { 35 | Carp::croak qq{Attribute "$attr" invalid} unless $attr =~ /^[a-zA-Z_]\w*$/; 36 | 37 | # Very performance sensitive code with lots of micro-optimizations 38 | if (ref $value) { 39 | _monkey_patch $class, $attr, sub { 40 | return 41 | exists $_[0]{$attr} ? $_[0]{$attr} : ($_[0]{$attr} = $value->($_[0])) 42 | if @_ == 1; 43 | $_[0]{$attr} = $_[1]; 44 | $_[0]; 45 | }; 46 | } 47 | elsif (defined $value) { 48 | _monkey_patch $class, $attr, sub { 49 | return exists $_[0]{$attr} ? $_[0]{$attr} : ($_[0]{$attr} = $value) 50 | if @_ == 1; 51 | $_[0]{$attr} = $_[1]; 52 | $_[0]; 53 | }; 54 | } 55 | else { 56 | _monkey_patch $class, $attr, 57 | sub { return $_[0]{$attr} if @_ == 1; $_[0]{$attr} = $_[1]; $_[0] }; 58 | } 59 | } 60 | } 61 | 62 | sub import { 63 | my $class = shift; 64 | return unless my $flag = shift; 65 | 66 | # Base 67 | if ($flag eq '-base') { $flag = $class } 68 | 69 | # Strict 70 | elsif ($flag eq '-strict') { $flag = undef } 71 | 72 | # Module 73 | elsif ((my $file = $flag) && !$flag->can('new')) { 74 | $file =~ s!::|'!/!g; 75 | require "$file.pm"; 76 | } 77 | 78 | # ISA 79 | if ($flag) { 80 | my $caller = caller; 81 | no strict 'refs'; 82 | push @{"${caller}::ISA"}, $flag; 83 | _monkey_patch $caller, 'has', sub { attr($caller, @_) }; 84 | } 85 | 86 | # Mojo modules are strict! 87 | $_->import for qw(strict warnings); 88 | feature->import(':5.10'); 89 | } 90 | 91 | sub new { 92 | my $class = shift; 93 | bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, ref $class || $class; 94 | } 95 | 96 | sub tap { 97 | my ($self, $cb) = (shift, shift); 98 | $_->$cb(@_) for $self; 99 | return $self; 100 | } 101 | 102 | 1; 103 | -------------------------------------------------------------------------------- /lib/Mojo/IRC/Server/Chinese/Channel.pm: -------------------------------------------------------------------------------- 1 | package Mojo::IRC::Server::Chinese::Channel; 2 | use Mojo::IRC::Server::Chinese::Base 'Mojo::IRC::Server::Chinese::Object'; 3 | use List::Util qw(first); 4 | has 'name'; 5 | has id => sub {lc $_[0]->name}; 6 | has topic => sub {"欢迎来到 " . $_[0]->name}; 7 | has ctime => sub {time()}; 8 | has mode => 'i'; 9 | has pass => undef; 10 | has user => sub {[]}; 11 | 12 | sub count { 13 | my $s = shift; 14 | 0+@{$s->user}; 15 | } 16 | sub add_user{ 17 | my $s = shift; 18 | my $uid = ref($_[0]) eq "Mojo::IRC::Server::Chinese::User"?$_[0]->id:$_[0]; 19 | push @{$s->user},$uid if not $s->is_has_user($uid); 20 | } 21 | sub remove_user{ 22 | my $s = shift; 23 | my $uid = ref($_[0]) eq "Mojo::IRC::Server::Chinese::User"?$_[0]->id:$_[0]; 24 | for(my $i=0;$i<@{$s->user};$i++){ 25 | if($uid eq $s->user->[$i]){ 26 | splice @{$s->user},$i,1; 27 | if(@{$s->user} == 0 and $s->mode !~/P/){ 28 | $s->{_server}->remove_channel($s); 29 | } 30 | return; 31 | } 32 | } 33 | } 34 | sub is_has_user{ 35 | my $s = shift; 36 | my $uid = ref($_[0]) eq "Mojo::IRC::Server::Chinese::User"?$_[0]->id:$_[0]; 37 | if(defined $uid){ 38 | return (first {$uid eq $_} @{$s->user})?1:0; 39 | } 40 | else{ 41 | return 0+@{$s->user}; 42 | } 43 | 44 | } 45 | sub set_topic{ 46 | my $s = shift; 47 | my $user = shift; 48 | my $topic = shift; 49 | $s->topic($topic); 50 | $s->broadcast($user->ident,"TOPIC",$s->name,$topic); 51 | $s->info($s->name . " 主题设置为: " . $s->topic); 52 | } 53 | sub set_mode{ 54 | my $s = shift; 55 | my $user = shift; 56 | my $mode = shift; 57 | $mode = "+" . $mode if (substr($mode,0,1) ne '+' and substr($mode,0,1) ne '-'); 58 | my %mode = map {$_=>1} split //,$s->mode; 59 | if(substr($mode,0,1) eq "+"){ 60 | $mode{$_}=1 for split //,substr($mode,1,); 61 | } 62 | elsif(substr($mode,0,1) eq "-"){ 63 | delete $mode{$_} for split //,substr($mode,1,); 64 | } 65 | else{ 66 | %mode = (); 67 | $mode{$_}=1 for split //,$mode; 68 | } 69 | $s->mode(join "",keys %mode); 70 | $s->broadcast($user->ident,"MODE",$s->name,$mode); 71 | $s->info("[" . $s->name . "] 模式设置为: " . $s->mode); 72 | } 73 | 74 | sub users{ 75 | my $s = shift; 76 | my @users = (); 77 | for my $uid (@{$s->user}){ 78 | my $user = $s->search_user(id=>$uid); 79 | push @users ,$user if defined $user; 80 | } 81 | return @users; 82 | } 83 | 84 | sub broadcast { 85 | my $s = shift; 86 | for my $user ($s->users){ 87 | $user->send(@_); 88 | } 89 | } 90 | 91 | sub forward { 92 | my $s = shift; 93 | my $except_user = shift; 94 | for my $user ($s->users){ 95 | next if $user->id eq $except_user->id; 96 | $user->send(@_); 97 | } 98 | } 99 | 100 | 1; 101 | -------------------------------------------------------------------------------- /lib/Mojo/IRC/Server/Chinese/Object.pm: -------------------------------------------------------------------------------- 1 | package Mojo::IRC::Server::Chinese::Object; 2 | use Mojo::IRC::Server::Chinese::Base 'Mojo::EventEmitter'; 3 | use Data::Dumper; 4 | sub dump { 5 | my $s = shift; 6 | print Dumper $s; 7 | } 8 | sub servername{ 9 | my $s = shift; 10 | $s->{_server}->servername; 11 | } 12 | sub serverident{ 13 | my $s = shift; 14 | $s->{_server}->ident; 15 | } 16 | 17 | sub new_channel { 18 | my $s= shift; 19 | return $s->{_server}->new_channel(@_); 20 | } 21 | sub search_channel{ 22 | my $s = shift; 23 | return $s->{_server}->search_channel(@_); 24 | } 25 | sub search_user{ 26 | my $s = shift; 27 | return $s->{_server}->search_user(@_); 28 | } 29 | 30 | sub die{ 31 | my $s = shift; 32 | $s->{_server}->die(@_); 33 | $s; 34 | } 35 | sub info{ 36 | my $s = shift; 37 | $s->{_server}->info(@_); 38 | $s; 39 | } 40 | sub warn{ 41 | my $s = shift; 42 | $s->{_server}->warn(@_); 43 | $s; 44 | } 45 | sub error{ 46 | my $s = shift; 47 | $s->{_server}->error(@_); 48 | $s; 49 | } 50 | sub fatal{ 51 | my $s = shift; 52 | $s->{_server}->fatal(@_); 53 | $s; 54 | } 55 | sub debug{ 56 | my $s = shift; 57 | $s->{_server}->debug(@_); 58 | $s; 59 | } 60 | 1; 61 | -------------------------------------------------------------------------------- /lib/Mojo/IRC/Server/Chinese/User.pm: -------------------------------------------------------------------------------- 1 | package Mojo::IRC::Server::Chinese::User; 2 | use Mojo::IRC::Server::Chinese::Base 'Mojo::IRC::Server::Chinese::Object'; 3 | use List::Util qw(first); 4 | has [qw(id name io)]; 5 | has user => '*'; 6 | has pass => undef; 7 | has nick => '*'; 8 | has mode => 'i'; 9 | has buffer => ''; 10 | has virtual => 0; 11 | has host => sub{$_[0]->virtual?"virtualhost":"hidden"}; 12 | has port => sub{$_[0]->virtual?"virtualport":"hidden"}; 13 | has ctime => sub{time()}; 14 | has 'last_speak_time'; 15 | has 'last_active_time'; 16 | has ping_count => 0; 17 | has close_reason => undef; 18 | has channel => sub{[]}; 19 | has realname => 'unset'; 20 | has is_quit => 0; 21 | has is_away => 0; 22 | has away_info => undef; 23 | 24 | sub is_registered { 25 | my $s = shift; 26 | if(@_==0){return $s->{is_registered}} 27 | else{ 28 | $s->{is_registered} = $_[0]; 29 | $s->{_server}->emit(user_registered=>$s); 30 | } 31 | return $s; 32 | } 33 | sub is_virtual { 34 | $_[0]->virtual; 35 | } 36 | sub away { 37 | my $s = shift; 38 | my $away_info = shift; 39 | $s->send($s->serverident,"306",$s->nick,"你已经被标记为离开"); 40 | $s->is_away(1); 41 | $s->set_mode("+a"); 42 | $s->away_info($away_info); 43 | } 44 | sub back { 45 | my $s = shift; 46 | $s->send($s->serverident,"305",$s->nick,"你不再被标记为离开"); 47 | $s->is_away(0); 48 | $s->set_mode("-a"); 49 | $s->away_info(undef); 50 | } 51 | sub quit{ 52 | my $s = shift; 53 | my $quit_reason = shift || ""; 54 | $s->broadcast($s->ident,"QUIT",$quit_reason); 55 | $s->info("[" . $s->name . "] 已退出($quit_reason)"); 56 | $s->io->close_gracefully() if not $s->is_virtual; 57 | $s->{_server}->remove_user($s); 58 | } 59 | sub ident{ 60 | my $s = shift; 61 | return $s->nick . '!' . $s->user . '@' . $s->host; 62 | } 63 | sub set_nick{ 64 | my $s = shift; 65 | my $nick = shift; 66 | $nick =~s/\s|\@|!//g; 67 | my $user = $s->search_user(nick=>$nick); 68 | if(defined $user and $user->id ne $s->id){ 69 | if($user->is_virtual){ 70 | $user->quit("虚拟帐号被移除"); 71 | $s->once(close=>sub{$s->{_server}->add_user($user)}); 72 | $s->broadcast($s->ident,NICK => $nick); 73 | $s->info("[" . $s->nick . "] 修改昵称为 [$nick]"); 74 | $s->nick($nick); 75 | $s->name($nick); 76 | if(!$s->is_registered and $s->nick ne "*" and $s->user ne "*"){ 77 | $s->is_registered(1); 78 | } 79 | } 80 | else{ 81 | $s->send($s->serverident,"433",$s->nick,$nick,'昵称已经被使用'); 82 | $s->info("昵称 [$nick] 已经被使用"); 83 | } 84 | } 85 | else{ 86 | if(defined $s->{_server}->auth and ref $s->{_server}->auth eq "CODE"){ 87 | if(! $s->{_server}->auth->($nick,$s->user,$s->pass)){ 88 | $s->send($s->serverident,"464",$s->nick,"认证失败"); 89 | return; 90 | } 91 | } 92 | $s->broadcast($s->ident,NICK => $nick); 93 | $s->info("[" . $s->nick . "] 修改昵称为 [$nick]"); 94 | $s->nick($nick); 95 | $s->name($nick); 96 | if(!$s->is_registered and $s->nick ne "*" and $s->user ne "*"){ 97 | $s->is_registered(1); 98 | } 99 | } 100 | } 101 | sub set_mode{ 102 | my $s = shift; 103 | my $mode = shift; 104 | my %mode = map {$_=>1} split //,$s->mode; 105 | if(substr($mode,0,1) eq "+"){ 106 | $mode{$_}=1 for split //,substr($mode,1,); 107 | } 108 | elsif(substr($mode,0,1) eq "-"){ 109 | delete $mode{$_} for split //,substr($mode,1,); 110 | } 111 | else{ 112 | %mode = (); 113 | $mode{$_}=1 for split //,$mode; 114 | } 115 | $s->mode(join "",keys %mode); 116 | $s->send($s->ident,"MODE",$s->nick,$mode); 117 | $s->info("[" . $s->nick . "] 模式设置为: " . $s->mode); 118 | } 119 | sub join_channel{ 120 | my $s = shift; 121 | my $channel; 122 | $channel = ref($_[0]) eq "Mojo::IRC::Server::Chinese::Channel"?$_[0]:$s->search_channel(id=>$_[0]); 123 | return if not defined $channel; 124 | if(not $s->is_join_channel($channel->id)){ 125 | push @{$s->channel},$channel->id; 126 | $channel->add_user($s->id); 127 | $channel->broadcast($s->ident,"JOIN",$channel->name); 128 | } 129 | else{$s->send($s->ident,"JOIN",$channel->name);} 130 | $s->send($s->serverident,"332",$s->nick,$channel->name,$channel->topic); 131 | $s->send($s->serverident,"353",$s->nick,'=',$channel->name,join " ",map {$_->nick} $channel->users); 132 | $s->send($s->serverident,"366",$s->nick,$channel->name,"End of NAMES list"); 133 | #$s->send($s->serverident,"329",$s->nick,$channel->name,$channel->ctime); 134 | $s->info("[" . $s->name . "] 加入频道 " . $channel->name); 135 | } 136 | sub part_channel{ 137 | my $s = shift; 138 | my $channel = ref($_[0]) eq "Mojo::IRC::Server::Chinese::Channel"?$_[0]:$s->search_channel(id=>$_[0]); 139 | my $part_info = $_[1]; 140 | return if not defined $channel; 141 | $channel->broadcast($s->ident,"PART",$channel->name,$part_info); 142 | for(my $i=0;$i<@{$s->channel};$i++){ 143 | if($channel->id eq $s->channel->[$i]){ 144 | splice @{$s->channel},$i,1; 145 | last; 146 | } 147 | } 148 | $channel->remove_user($s->id); 149 | $s->info("[" . $s->nick . "] 离开频道 " . $channel->name); 150 | 151 | } 152 | sub is_join_channel{ 153 | my $s = shift; 154 | my $cid = ref($_[0]) eq "Mojo::IRC::Server::Chinese::Channel"?$_[0]->id:$_[0]; 155 | if(defined $cid){ 156 | return (first {$cid eq $_} @{$s->channel})?1:0; 157 | } 158 | else{ 159 | return 0+@{$s->channel}; 160 | } 161 | } 162 | sub forward{ 163 | my $s = shift; 164 | my %unique; 165 | for my $channel ($s->channels){ 166 | for my $user ($channel->users){ 167 | next if $user->id eq $s->id; 168 | next if exists $unique{$user->id}; 169 | $user->send(@_); 170 | $unique{$user->id} = 1; 171 | } 172 | } 173 | } 174 | 175 | sub broadcast{ 176 | my $s = shift; 177 | $s->send(@_); 178 | my %unique; 179 | for my $channel ($s->channels){ 180 | for my $user ($channel->users){ 181 | next if $user->id eq $s->id; 182 | next if exists $unique{$user->id}; 183 | $user->send(@_); 184 | $unique{$user->id} = 1; 185 | } 186 | } 187 | } 188 | sub channels{ 189 | my $s = shift; 190 | my @channels = (); 191 | for my $cid (@{$s->channel}){ 192 | my $channel = $s->search_channel(id=>$cid); 193 | push @channels ,$channel if defined $channel; 194 | } 195 | return @channels; 196 | } 197 | sub each_channel{ 198 | my $s = shift; 199 | my $callback = shift; 200 | return if not $s->is_join_channel(); 201 | for my $cid (@{$s->channel}){ 202 | my $channel = $s->search_channel(id=>$cid); 203 | $callback->($s,$channel,@_) if defined $channel; 204 | } 205 | } 206 | 207 | sub send{ 208 | my $s = shift; 209 | return if $s->is_virtual ; 210 | my($prefix,$command,@params)=@_; 211 | my $msg = ""; 212 | $msg .= defined $prefix ? ":$prefix " : ""; 213 | $msg .= $command; 214 | my $trail; 215 | $trail = pop @params; 216 | $msg .= " $_" for @params; 217 | $msg .= defined $trail ? " :$trail" : ""; 218 | $msg .= "\r\n"; 219 | $s->io->write($msg); 220 | $s->debug("S[".$s->name."] $msg"); 221 | } 222 | sub is_localhost{ 223 | my $s = shift; 224 | return 0 if $s->is_virtual; 225 | return 1 if $s->io->handle->peerhost eq "127.0.0.1"; 226 | } 227 | 1; 228 | -------------------------------------------------------------------------------- /t/load_module.t: -------------------------------------------------------------------------------- 1 | # Before `make install' is performed this script should be runnable with 2 | # `make test'. After `make install' it should work as `perl load_module.t' 3 | 4 | ######################### 5 | 6 | # change 'tests => 1' to 'tests => last_test_to_print'; 7 | use Test::More tests => 1; 8 | BEGIN { use_ok('Mojo::IRC::Server::Chinese') }; 9 | 10 | ######################### 11 | 12 | # Insert your test code below, the Test::More module is use()ed here so read 13 | # its man page ( perldoc Test::More ) for help writing this test script. 14 | --------------------------------------------------------------------------------