├── lib ├── pfqq.pm ├── Webqq │ ├── Client │ │ ├── Plugin │ │ │ ├── About.pm │ │ │ ├── ClientStore.pm │ │ │ ├── SmartReply2.pm │ │ │ ├── SendMsgControl.pm │ │ │ ├── SendMsgFromMsg.pm │ │ │ ├── HelloGirl.pm │ │ │ ├── PicLimit.pm │ │ │ ├── Openqq.pm │ │ │ ├── IrcSync.pm │ │ │ ├── SendMsgFromSocket.pm │ │ │ ├── CpanRecentModule.pm │ │ │ ├── LinkInfo.pm │ │ │ ├── PostImgVerifycode.pm │ │ │ ├── Msgstat.pm │ │ │ ├── SmartReply.pm │ │ │ ├── Perlcode.pm │ │ │ ├── ShowMsg.pm │ │ │ ├── MsgSync.pm │ │ │ └── Perldoc.pm │ │ ├── Method │ │ │ ├── _report.pm │ │ │ ├── _cookie_proxy.pm │ │ │ ├── _check_sig.pm │ │ │ ├── get_dwz.pm │ │ │ ├── _get_msg_tip.pm │ │ │ ├── change_state.pm │ │ │ ├── _get_recent_info.pm │ │ │ ├── logout.pm │ │ │ ├── _get_vfwebqq.pm │ │ │ ├── _get_group_list_info.pm │ │ │ ├── _get_friends_state.pm │ │ │ ├── _get_stranger_info.pm │ │ │ ├── get_single_long_nick.pm │ │ │ ├── _get_discuss_list_info.pm │ │ │ ├── _login2.pm │ │ │ ├── _get_group_sig.pm │ │ │ ├── _get_user_info.pm │ │ │ ├── _prepare_for_login.pm │ │ │ ├── get_qq_from_uin.pm │ │ │ ├── _recv_message.pm │ │ │ ├── _get_offpic.pm │ │ │ ├── _get_friend_info.pm │ │ │ ├── _relink.pm │ │ │ ├── _send_discuss_message.pm │ │ │ ├── _get_img_verify_code.pm │ │ │ ├── _send_group_message.pm │ │ │ ├── _send_message.pm │ │ │ ├── _send_sess_message.pm │ │ │ ├── _get_user_friends.pm │ │ │ ├── _check_verify_code.pm │ │ │ ├── _get_discuss_info.pm │ │ │ ├── _get_group_info.pm │ │ │ └── _login1.pm │ │ ├── Cache.pm │ │ ├── Plugin.pm │ │ ├── Cron.pm │ │ └── Util.pm │ ├── Message │ │ ├── Queue.pm │ │ └── Face.pm │ ├── UserAgent.pm │ └── Message.pm └── Plack │ ├── App │ ├── robots.pm │ └── Openqq │ │ ├── GetDiscuss.pm │ │ ├── GetUserInfo.pm │ │ ├── GetFriendInfo.pm │ │ ├── GetGroupInfo.pm │ │ ├── GetRecentInfo.pm │ │ ├── GetDiscussInfo.pm │ │ ├── SendDiscussMessage.pm │ │ ├── SendMessage.pm │ │ ├── SendGroupMessage.pm │ │ └── SendSessMessage.pm │ └── Middleware │ └── Openqq │ └── SelfTalkForbid.pm ├── t ├── load_module.t └── https.t ├── demo ├── console_message.pl └── echo.pl ├── Makefile.PL ├── README └── Changes /lib/pfqq.pm: -------------------------------------------------------------------------------- 1 | package pfqq; 2 | use base qw(Webqq::Client); 3 | our $VERION = "8.5.3"; 4 | 1; 5 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Plugin/About.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Plugin::About; 2 | sub call{ 3 | my $client= shift; 4 | my $msg = shift; 5 | 6 | } 7 | 1; 8 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Plugin/ClientStore.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Plugin::ClientStore; 2 | use Storable; 3 | sub call{ 4 | my $client = shift; 5 | my $path = shift; 6 | store($client->{qq_database},$path); 7 | return 1; 8 | } 9 | 1; 10 | -------------------------------------------------------------------------------- /lib/Plack/App/robots.pm: -------------------------------------------------------------------------------- 1 | package Plack::App::robots; 2 | use strict; 3 | use parent qw(Plack::Component); 4 | sub call { 5 | my($self,$env) = @_; 6 | return [ 7 | '200', 8 | ['Content-Type','text/plain'], 9 | ["User-agent: *\r\nDisallow: /"] 10 | ]; 11 | } 12 | 1; 13 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_report.pm: -------------------------------------------------------------------------------- 1 | sub Webqq::Client::_report { 2 | my $self = shift; 3 | return 1; 4 | return 1 if $self->{type} ne 'smartqq'; 5 | console "上报登录状态...\n"; 6 | my $ua = $self->{ua}; 7 | my $response = $ua->get('https://ui.ptlogin2.qq.com/cgi-bin/report?id=488358'); 8 | print $response->content(),"\n" if $self->{debug}; 9 | return 1; 10 | } 11 | 1; 12 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_cookie_proxy.pm: -------------------------------------------------------------------------------- 1 | sub Webqq::Client::_cookie_proxy { 2 | my $self = shift; 3 | return 1 if $self->{type} ne 'smartqq'; 4 | my $p_skey = $self->search_cookie("p_skey"); 5 | my $p_uin = $self->search_cookie("p_uin"); 6 | $self->{cookie_jar}->set_cookie(0,"p_skey",$p_skey,"/","w.qq.com"); 7 | $self->{cookie_jar}->set_cookie(0,"p_uin",$p_skey,"/","w.qq.com"); 8 | return 1; 9 | }; 10 | 1; 11 | -------------------------------------------------------------------------------- /lib/Plack/App/Openqq/GetDiscuss.pm: -------------------------------------------------------------------------------- 1 | package Plack::App::Openqq::GetUserInfo; 2 | use parent qw(Plack::Component); 3 | use URI::Escape qw(uri_unescape); 4 | use JSON; 5 | sub call{ 6 | my $self = shift; 7 | my $client = $self->{client}; 8 | my $env = shift; 9 | return [ 10 | 200, 11 | ['Content-Type' => 'text/plain'], 12 | [JSON->new->encode($client->{qq_database}{discuss})], 13 | ]; 14 | } 15 | 1; 16 | -------------------------------------------------------------------------------- /lib/Plack/App/Openqq/GetUserInfo.pm: -------------------------------------------------------------------------------- 1 | package Plack::App::Openqq::GetUserInfo; 2 | use parent qw(Plack::Component); 3 | use URI::Escape qw(uri_unescape); 4 | use JSON; 5 | sub call{ 6 | my $self = shift; 7 | my $client = $self->{client}; 8 | my $env = shift; 9 | return [ 10 | 200, 11 | ['Content-Type' => 'text/plain'], 12 | [JSON->new->encode($client->{qq_database}{user})], 13 | ]; 14 | } 15 | 1; 16 | -------------------------------------------------------------------------------- /lib/Plack/App/Openqq/GetFriendInfo.pm: -------------------------------------------------------------------------------- 1 | package Plack::App::Openqq::GetFriendInfo; 2 | use parent qw(Plack::Component); 3 | use URI::Escape qw(uri_unescape); 4 | use JSON; 5 | sub call{ 6 | my $self = shift; 7 | my $client = $self->{client}; 8 | my $env = shift; 9 | return [ 10 | 200, 11 | ['Content-Type' => 'text/plain'], 12 | [JSON->new->encode($client->{qq_database}{friends})], 13 | ]; 14 | } 15 | 1; 16 | -------------------------------------------------------------------------------- /lib/Plack/App/Openqq/GetGroupInfo.pm: -------------------------------------------------------------------------------- 1 | package Plack::App::Openqq::GetGroupInfo; 2 | use parent qw(Plack::Component); 3 | use URI::Escape qw(uri_unescape); 4 | use JSON; 5 | sub call{ 6 | my $self = shift; 7 | my $client = $self->{client}; 8 | my $env = shift; 9 | return [ 10 | 200, 11 | ['Content-Type' => 'text/plain'], 12 | [JSON->new->encode($client->{qq_database}{group})], 13 | ]; 14 | } 15 | 1; 16 | -------------------------------------------------------------------------------- /lib/Plack/App/Openqq/GetRecentInfo.pm: -------------------------------------------------------------------------------- 1 | package Plack::App::Openqq::GetRecentInfo; 2 | use parent qw(Plack::Component); 3 | use URI::Escape qw(uri_unescape); 4 | use JSON; 5 | sub call{ 6 | my $self = shift; 7 | my $client = $self->{client}; 8 | my $env = shift; 9 | return [ 10 | 200, 11 | ['Content-Type' => 'text/plain'], 12 | [JSON->new->encode($client->{qq_database}{recent})], 13 | ]; 14 | } 15 | 1; 16 | -------------------------------------------------------------------------------- /lib/Plack/App/Openqq/GetDiscussInfo.pm: -------------------------------------------------------------------------------- 1 | package Plack::App::Openqq::GetDiscussInfo; 2 | use parent qw(Plack::Component); 3 | use URI::Escape qw(uri_unescape); 4 | use JSON; 5 | sub call{ 6 | my $self = shift; 7 | my $client = $self->{client}; 8 | my $env = shift; 9 | return [ 10 | 200, 11 | ['Content-Type' => 'text/plain'], 12 | [JSON->new->encode($client->{qq_database}{discuss})], 13 | ]; 14 | } 15 | 1; 16 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_check_sig.pm: -------------------------------------------------------------------------------- 1 | use Webqq::Client::Util qw(console); 2 | sub Webqq::Client::_check_sig { 3 | console "检查安全代码...\n"; 4 | my $self = shift; 5 | my $api_url = $self->{qq_param}{api_check_sig}; 6 | my $ua = $self->{ua}; 7 | for(my $i=0;$i<=$self->{ua_retry_times};$i++){ 8 | my $response = $ua->get($api_url); 9 | if($response->is_success){ 10 | return 1; 11 | } 12 | } 13 | return 0; 14 | } 15 | 1; 16 | -------------------------------------------------------------------------------- /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 LWP::UserAgent; 8 | use Test::More tests => 1; 9 | BEGIN { use_ok('Webqq::Client') }; 10 | 11 | ######################### 12 | 13 | # Insert your test code below, the Test::More module is use()ed here so read 14 | # its man page ( perldoc Test::More ) for help writing this test script. 15 | -------------------------------------------------------------------------------- /demo/console_message.pl: -------------------------------------------------------------------------------- 1 | #将接收到的普通信息和群信息打印到终端 2 | use lib '../lib/'; 3 | use Webqq::Client; 4 | use Digest::MD5 qw(md5_hex); 5 | 6 | my $qq = 12345678 ; 7 | my $pwd = md5_hex('your password'); 8 | 9 | #初始化客户端 10 | my $client = Webqq::Client->new(debug=>0); 11 | 12 | #登录 13 | $client->login( qq=> $qq, pwd => $pwd); 14 | 15 | #加载Webqq::Client::Plugin::ShowMsg插件 16 | $client->load("ShowMsg"); 17 | 18 | $client->on_send_message = sub{ 19 | my $msg = shift; 20 | #执行插件，打印发送的消息 21 | $client->call("ShowMsg",$msg); 22 | }; 23 | $client->on_receive_message = sub{ 24 | my $msg = shift; 25 | #执行插件，打印接收到的消息 26 | $client->call("ShowMsg",$msg); 27 | }; 28 | $client->run; 29 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Plugin/SmartReply2.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Plugin::SmartReply2; 2 | my $API = 'http://www.xiaodoubi.com/bot/api.php?chat='; 3 | sub call{ 4 | my $client = shift; 5 | my $msg = shift; 6 | my $res; 7 | eval{ 8 | local $SIG{ALRM} = sub{die "timout\n"}; 9 | alarm 5; 10 | $res = $client->{ua}->get($API . $msg->{content}); 11 | alarm 0; 12 | }; 13 | print "Webqq::Client::App::SmartReply请求超时\n" if $@ and $client->{debug}; 14 | if($res->is_success){ 15 | my $data = $res->content; 16 | $data=~s/小逗比/小灰/g; 17 | if($data){ 18 | $client->reply_message($msg,$data); 19 | } 20 | } 21 | else{return undef} 22 | 23 | } 24 | 1; 25 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/get_dwz.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Webqq::Client::Util qw(console); 3 | sub Webqq::Client::get_dwz { 4 | my $self = shift; 5 | my $url = shift; 6 | my $api = 'http://dwz.cn/create.php'; 7 | my $ua = $self->{ua}; 8 | my $res; 9 | my $dwz; 10 | eval{ 11 | local $SIG{ALRM} = sub{die "timeout";}; 12 | alarm 5; 13 | $res = $ua->post($api,[url=>$url],); 14 | alarm 0; 15 | if($res->is_success){ 16 | my $json = JSON->new->utf8->decode($res->content); 17 | $dwz = $json->{tinyurl} if $json->{status}==0; 18 | }; 19 | }; 20 | console "[Webqq::Client::get_dwz] $@\n" if $@ and $self->{debug}; 21 | 22 | return $dwz; 23 | 24 | }; 25 | 1; 26 | -------------------------------------------------------------------------------- /lib/Plack/Middleware/Openqq/SelfTalkForbid.pm: -------------------------------------------------------------------------------- 1 | package Plack::Middleware::Openqq::SelfTalkForbid; 2 | use parent qw(Plack::Middleware); 3 | sub call{ 4 | my($self,$env) = @_; 5 | my $client = $self->{client}; 6 | my %query_string; 7 | for my $query_string (split(/&/,$env->{QUERY_STRING} )){ 8 | my($key,$value) = split /=/,$query_string; 9 | $query_string{$key} = $value; 10 | } 11 | if(defined $query_string{qq}){ 12 | return ['403',[],[]] if $query_string{qq} eq $client->{qq_database}{user}{qq}; 13 | } 14 | elsif(defined $query_string{uin}){ 15 | return ['403',[],[]] if $query_string{uin} eq $client->{qq_database}{user}{uin}; 16 | } 17 | my $res = $self->app->($env); 18 | return $res; 19 | } 20 | 1; 21 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Plugin/SendMsgControl.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Plugin::SendMsgControl; 2 | use Webqq::Client::Util qw(console); 3 | sub call{ 4 | my($client,$msg) = @_; 5 | if($msg->{content}=~/^-shutdown$/){ 6 | my $from_qq = $msg->from_qq; 7 | return unless $from_qq == 308165330; 8 | $client->reply_message($msg,"系统已关闭消息发送功能"); 9 | $client->{send_message_queue}->{callback_for_get} = sub{return;}; 10 | console("系统已关闭消息发送功能\n") if $client->{debug}; 11 | } 12 | elsif($msg->{content}=~/^-reactive$/){ 13 | my $from_qq = $msg->from_qq; 14 | return unless $from_qq == 308165330; 15 | $client->{send_message_queue}->{callback_for_get} = 16 | $client->{send_message_queue}->{callback_for_get_bak} ; 17 | console("系统已重新开启消息发送功能\n") if $client->{debug}; 18 | $client->reply_message($msg,"系统已重新开启消息发送功能"); 19 | } 20 | return 1; 21 | } 22 | 1; 23 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Cache.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Cache; 2 | sub new{ 3 | return bless {} 4 | } 5 | sub store { 6 | my $self= shift; 7 | my ($data_key,$data,$ttl) = @_; 8 | $self->{$data_key}{data} = $data; 9 | $self->{$data_key}{ttl} = $ttl; 10 | $self->{$data_key}{ctime} = time; 11 | 12 | } 13 | sub delete { 14 | my $self= shift; 15 | my $data_key = shift; 16 | delete $self->{$data_key}; 17 | } 18 | sub retrieve{ 19 | my $self = shift; 20 | my $data_key = shift; 21 | if(exists $self->{$data_key} ){ 22 | if(defined $self->{$data_key}{ttl}){ 23 | if($self->{$data_key}{ttl} + $self->{$data_key}{ctime} > time){ 24 | return $self->{$data_key}{data}; 25 | } 26 | else{delete $self->{$data_key};return undef} 27 | } 28 | else{ 29 | return $self->{$data_key}{data}; 30 | } 31 | } 32 | else{return undef} 33 | } 34 | 1; 35 | -------------------------------------------------------------------------------- /lib/Webqq/Message/Queue.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Message::Queue; 2 | sub new{ 3 | my $class = shift; 4 | my $self = { 5 | queue => [], 6 | callback_for_get => undef, 7 | callback_for_get_bak => undef, 8 | }; 9 | return bless $self,$class; 10 | } 11 | 12 | sub put{ 13 | my $self = shift; 14 | die "Webqq::Message::Queue->put()失败，请检查是否已经设置了队列get()回调\n" 15 | unless ref $self->{callback_for_get} eq 'CODE'; 16 | push @{ $self->{queue} } ,$_[0]; 17 | $self->_notify_to_get(); 18 | } 19 | sub get{ 20 | my $self = shift; 21 | my $cb = shift; 22 | die "Webqq::Message::Queue->get()仅接受一个函数引用\n" unless ref $cb eq 'CODE'; 23 | $self->{callback_for_get} = $cb; 24 | $self->{callback_for_get_bak} = $cb; 25 | } 26 | sub _notify_to_get{ 27 | my $self = shift; 28 | my $msg = shift @{$self->{queue}}; 29 | $self->{callback_for_get}->($msg); 30 | } 31 | 32 | 1; 33 | -------------------------------------------------------------------------------- /t/https.t: -------------------------------------------------------------------------------- 1 | # Before `make install' is performed this script should be runnable with 2 | # `make test'. After `make install' it should work as `perl https.t' 3 | 4 | ######################### 5 | 6 | # change 'tests => 1' to 'tests => last_test_to_print'; 7 | use LWP::UserAgent; 8 | use Test::More tests => 1; 9 | ok( 10 | LWP::UserAgent->new->get( 11 | 'https://ui.ptlogin2.qq.com/cgi-bin/login?daid=164&target=self&style=16&mibao_css=m_webqq&appid=501004106&enable_qlogin=0&no_verifyimg=1&s_url=http%3A%2F%2Fw.qq.com%2Fproxy.html&f_url=loginerroralert&strong_login=1&login_state=10&t=20131024001', 12 | ( 13 | Referer=>'http://w.qq.com/', 14 | "User-Agent"=>'Mozilla/5.0 (Windows NT 6.1) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/39.0.2171.65' ) 15 | )->code == 200,"https support" 16 | ); 17 | 18 | ######################### 19 | 20 | # Insert your test code below, the Test::More module is use()ed here so read 21 | # its man page ( perldoc Test::More ) for help writing this test script. 22 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_get_msg_tip.pm: -------------------------------------------------------------------------------- 1 | use Webqq::Client::Util qw(console); 2 | sub Webqq::Client::_get_msg_tip{ 3 | my $self = shift; 4 | my $ua = $self->{asyn_ua}; 5 | my $api_url = 'http://web2.qq.com/web2/get_msg_tip'; 6 | my @headers = ( 7 | Referer => 'http://web2.qq.com/webqq.html', 8 | 'Content-Type' => 'utf-8', 9 | ); 10 | my @query_string = ( 11 | uin => undef, 12 | tp => 1, 13 | id => 0, 14 | retype => 1, 15 | rc => $self->{qq_param}{rc}++, 16 | lv => 3, 17 | t => time, 18 | ); 19 | 20 | my @query_string_pairs; 21 | push @query_string_pairs , shift(@query_string) . "=" . shift(@query_string) while(@query_string); 22 | print $api_url.'?'.join("&",@query_string_pairs),"\n" if $self->{debug}; 23 | $ua->get($api_url.'?'.join("&",@query_string_pairs),@headers,sub{ 24 | my $response = shift; 25 | console "心跳检测\n" if $self->{debug}; 26 | }); 27 | } 28 | 1; 29 | -------------------------------------------------------------------------------- /lib/Webqq/Message/Face.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Message::Face; 2 | use Exporter 'import'; 3 | @EXPORT=qw(face_to_txt); 4 | my %FACE_MAP = qw( 5 | 0 惊讶 6 | 1 撇嘴 7 | 2 色 8 | 3 发呆 9 | 4 得意 10 | 5 流泪 11 | 6 害羞 12 | 7 闭嘴 13 | 8 睡 14 | 9 大哭 15 | 10 尴尬 16 | 11 发怒 17 | 12 调皮 18 | 13 呲牙 19 | 14 微笑 20 | 33 玫瑰 21 | 34 凋谢 22 | 36 爱心 23 | 46 强 24 | 50 难过 25 | 51 酷 26 | 53 抓狂 27 | 54 吐 28 | 55 惊恐 29 | 56 流汗 30 | 57 憨笑 31 | 58 大兵 32 | 72 便便 33 | 73 偷笑 34 | 74 可爱 35 | 75 白眼 36 | 76 傲慢 37 | 77 饥饿 38 | 78 困 39 | 79 奋斗 40 | 80 咒骂 41 | 81 疑问 42 | 82 嘘 43 | 83 晕 44 | 84 折磨 45 | 85 衰 46 | 87 敲打 47 | 96 冷汗 48 | 118 抱拳 49 | 50 | ); 51 | sub face_to_txt{ 52 | my $face = shift; 53 | if(ref $face eq 'ARRAY'){ 54 | return "[未知表情]" if $face->[0] ne "face"; 55 | return "[系统表情]" unless exists $FACE_MAP{$face->[1]}; 56 | return "[" . $FACE_MAP{$face->[1]} . "]"; 57 | } 58 | else{ 59 | return $face; 60 | } 61 | } 62 | 1; 63 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/change_state.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Webqq::Client::Util qw(console); 3 | sub Webqq::Client::change_state{ 4 | my $self = shift; 5 | return undef if $self->{type} ne 'smartqq'; 6 | my $state = shift; 7 | my $api_url = 'http://d.web2.qq.com/channel/change_status2'; 8 | my $ua = $self->{ua}; 9 | my @headers = ( 10 | Referer=>'http://d.web2.qq.com/proxy.html?v=20130916001&callback=1&id=2' 11 | ); 12 | my @query_string = ( 13 | newstatus => $state, 14 | clientid => $self->{qq_param}{clientid}, 15 | psessionid => $self->{qq_param}{psessionid}, 16 | t => time, 17 | ); 18 | 19 | my @query_string_pairs; 20 | push @query_string_pairs , shift(@query_string) . "=" . shift(@query_string) while(@query_string); 21 | my $response = $ua->get($api_url.'?'.join("&",@query_string_pairs),@headers); 22 | if($response->is_success){ 23 | print $response->content(),"\n" if $self->{debug}; 24 | my $json = JSON->new->utf8->decode( $response->content() ); 25 | return undef if $json->{retcode} !=0; 26 | console "登录状态已修改为：$state\n"; 27 | return $state; 28 | } 29 | else{return undef} 30 | } 31 | 1; 32 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_get_recent_info.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | sub Webqq::Client::_get_recent_info { 3 | my $self = shift; 4 | my $ua = $self->{ua}; 5 | return undef if $self->{type} ne 'smartqq'; 6 | my $api_url = 'http://d.web2.qq.com/channel/get_recent_list2'; 7 | my @headers = ( 8 | Referer => 'http://d.web2.qq.com/proxy.html?v=20130916001&callback=1&id=2', 9 | ); 10 | 11 | my %r = ( 12 | vfwebqq => $self->{qq_param}{vfwebqq}, 13 | clientid => $self->{qq_param}{clientid}, 14 | psessionid => $self->{qq_param}{psessionid}, 15 | ); 16 | my $response = $ua->post($api_url,[r=>JSON->new->utf8->encode(\%r)],@headers); 17 | if($response->is_success){ 18 | print $response->content(),"\n" if $self->{debug}; 19 | my $json = JSON->new->utf8->decode($response->content()); 20 | return undef if $json->{retcode}!=0 ; 21 | my %type = (0 => 'friend',1 => 'group', 2 => 'discuss'); 22 | my @recent; 23 | for(@{$json->{result}}){ 24 | next unless exists $type{$_->{type}}; 25 | $_->{type} = $type{$_->{type}}; 26 | push @recent,$_; 27 | } 28 | return @recent>0?\@recent:undef; 29 | } 30 | 31 | } 32 | 1; 33 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/logout.pm: -------------------------------------------------------------------------------- 1 | use Webqq::Client::Util qw(console); 2 | sub Webqq::Client::logout { 3 | my $self = shift; 4 | console "正在注销...\n"; 5 | if($self->{type} eq 'smartqq'){ 6 | $self->{cookie_jar}->set_cookie(0,"ptwebqq",undef,"/","qq.com",undef,undef,undef,-1); 7 | $self->{cookie_jar}->set_cookie(0,"skey",undef,"/","qq.com",undef,undef,undef,-1); 8 | console "注销完毕\n"; 9 | return 1; 10 | } 11 | my $ua = $self->{ua}; 12 | my $api_url = 'http://d.web2.qq.com/channel/logout2'; 13 | my @query_string = ( 14 | ids => undef, 15 | clientid => $self->{qq_param}{clientid}, 16 | psessionid => $self->{qq_param}{psessionid}, 17 | t => time, 18 | ); 19 | my @headers = (Referer => 'http://d.web2.qq.com/proxy.html?v=20110331002&callback=1&id=3'); 20 | my @query_string_pairs; 21 | push @query_string_pairs , shift(@query_string) . "=" . shift(@query_string) while(@query_string); 22 | my $response = $ua->get($api_url.'?'.join("&",@query_string_pairs),@headers); 23 | if($response->is_success){ 24 | my $content = $response->content(); 25 | print $content,"\n" if $self->{debug}; 26 | console "注销完毕\n"; 27 | return 1; 28 | } 29 | else{return 0} 30 | } 31 | 1; 32 | -------------------------------------------------------------------------------- /lib/Plack/App/Openqq/SendDiscussMessage.pm: -------------------------------------------------------------------------------- 1 | package Plack::App::Openqq::SendDiscussMessage; 2 | use parent qw(Plack::Component); 3 | use URI::Escape qw(uri_unescape); 4 | use JSON; 5 | use Encode; 6 | sub call{ 7 | my $self = shift; 8 | my $client = $self->{client}; 9 | my $env = shift; 10 | my %query_string; 11 | for my $query_string (split(/&/,$env->{QUERY_STRING} )){ 12 | my($key,$value) = split /=/,$query_string; 13 | $query_string{$key} = $value; 14 | } 15 | my $uin = $query_string{uin} || $query_string{did}; 16 | my $content = uri_unescape($query_string{content}); 17 | 18 | return sub { 19 | my $responder = shift; 20 | my $msg = $client->create_discuss_msg(to_uin=>$uin,content=>$content); 21 | $msg->{cb} = sub{ 22 | my($msg,$is_success,$status) = @_; 23 | my $res = { 24 | msg_id => $msg->{msg_id}, 25 | code => $is_success, 26 | status => decode("utf8",$status), 27 | }; 28 | my $json = JSON->new->utf8->encode($res); 29 | $responder->([ 30 | 200, 31 | ['Content-Type' => 'text/plain'], 32 | [$json], 33 | ]); 34 | }; 35 | $client->send_discuss_message($msg); 36 | }; 37 | 38 | } 39 | 1; 40 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Plugin/SendMsgFromMsg.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Plugin::SendMsgFromMsg; 2 | use Webqq::Client::Util qw(console); 3 | my %GROUP_MARKNAME = qw( 4 | test IT狂人 5 | a PERL学习交流 6 | b perl技术 7 | c PERL 8 | ); 9 | 10 | sub call{ 11 | my $client = shift; 12 | my $msg = shift; 13 | if($msg->{content} =~/^(?::m)(?:\n|[\t ]+)(.*?)(?:\n^|[\t ]+)(?::e)$/ms){ 14 | my $command = $1; 15 | open my $fh,"<",\$command or return; 16 | while(<$fh>){ 17 | chomp; 18 | my $line = $_; 19 | console "从消息接收到发送消息指令: " . $line . "\n"; 20 | my($group,$content) = split(/\s+/,$line,2); 21 | $group = $GROUP_MARKNAME{$group} if exists $GROUP_MARKNAME{$group}; 22 | my $gid = undef; 23 | for(@{$client->{qq_database}{group_list}}){ 24 | if($_->{name} eq $group or $_->{markname} eq $group){ 25 | $gid = $_->{gid} ; 26 | last; 27 | } 28 | } 29 | if(defined $gid){ 30 | $client->send_group_message( 31 | $client->create_group_msg( to_uin=>$gid,content=>$content) 32 | ); 33 | } 34 | } 35 | 36 | close $fh; 37 | } 38 | 39 | return 1; 40 | } 41 | 42 | 1; 43 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_get_vfwebqq.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Webqq::Client::Util qw(console); 3 | sub Webqq::Client::_get_vfwebqq { 4 | my $self = shift; 5 | return 1 if $self->{type} ne 'smartqq'; 6 | console "获取vfwebqq值...\n"; 7 | my $api_url = 'http://s.web2.qq.com/api/getvfwebqq'; 8 | my @query_string = ( 9 | ptwebqq => $self->{qq_param}{ptwebqq}, 10 | clientid => $self->{qq_param}{clientid}, 11 | psessionid => undef, 12 | t => rand(), 13 | ); 14 | my @headers = ( 15 | Referer => 'http://s.web2.qq.com/proxy.html?v=20130916001&callback=1&id=1', 16 | ); 17 | my @query_string_pairs; 18 | push @query_string_pairs , shift(@query_string) . "=" . shift(@query_string) while(@query_string); 19 | 20 | my $ua = $self->{ua}; 21 | my $response = $ua->get($api_url . '?' .join("&",@query_string_pairs),@headers); 22 | if($response->is_success){ 23 | print $response->content,"\n" if $self->{debug}; 24 | my $json = JSON->new->utf8->decode($response->content); 25 | if($json->{retcode}!=0){ 26 | console "获取vfwebqq值失败...\n"; 27 | return 0; 28 | } 29 | $self->{qq_param}{vfwebqq} = $json->{result}{vfwebqq}; 30 | return $json->{result}{vfwebqq}; 31 | } 32 | else{ 33 | console "获取vfwebqq值失败...\n"; 34 | return 0; 35 | } 36 | } 37 | 1; 38 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_get_group_list_info.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | sub Webqq::Client::_get_group_list_info{ 3 | my $self = shift; 4 | my $ua = $self->{ua}; 5 | my $api_url = 'http://s.web2.qq.com/api/get_group_name_list_mask2'; 6 | my @headers = $self->{type} eq 'webqq'? (Referer => 'http://s.web2.qq.com/proxy.html?v=20110412001&callback=1&id=3') 7 | : (Referer => 'http://s.web2.qq.com/proxy.html?v=20130916001&callback=1&id=1') 8 | ; 9 | my %r = ( 10 | hash => hash($self->{qq_param}{ptwebqq},$self->{qq_param}{qq}), 11 | vfwebqq => $self->{qq_param}{vfwebqq}, 12 | ); 13 | 14 | my $post_content = [ 15 | r => JSON->new->encode(\%r), 16 | ]; 17 | 18 | #if($self->{debug}){ 19 | # require URI; 20 | # my $uri = URI->new('http:'); 21 | # $uri->query_form($post_content); 22 | # print $api_url,"\n"; 23 | # print $uri->query(),"\n"; 24 | #} 25 | 26 | my $response = $ua->post( 27 | $api_url, 28 | $post_content, 29 | @headers, 30 | ); 31 | if($response->is_success){ 32 | print $response->content(),"\n" if $self->{debug}; 33 | my $json = JSON->new->utf8->decode( $response->content() ); 34 | return undef unless exists $json->{result}{gnamelist}; 35 | return $json->{result}; 36 | } 37 | else{return undef} 38 | } 39 | 1; 40 | -------------------------------------------------------------------------------- /lib/Plack/App/Openqq/SendMessage.pm: -------------------------------------------------------------------------------- 1 | package Plack::App::Openqq::SendMessage; 2 | use parent qw(Plack::Component); 3 | use URI::Escape qw(uri_unescape); 4 | use JSON; 5 | use Encode; 6 | sub call{ 7 | my $self = shift; 8 | my $client = $self->{client}; 9 | my $env = shift; 10 | my %query_string; 11 | for my $query_string (split(/&/,$env->{QUERY_STRING} )){ 12 | my($key,$value) = split /=/,$query_string; 13 | $query_string{$key} = $value; 14 | } 15 | my $uin; 16 | if(defined $query_string{qq}){ 17 | $uin = $client->get_uin_from_qq($query_string{qq}); 18 | } 19 | else{ 20 | $uin = $query_string{uin}; 21 | } 22 | my $content = uri_unescape($query_string{content}); 23 | 24 | return sub { 25 | my $responder = shift; 26 | my $msg = $client->create_msg(to_uin=>$uin,content=>$content); 27 | $msg->{cb} = sub{ 28 | my($msg,$is_success,$status) = @_; 29 | my $res = { 30 | msg_id => $msg->{msg_id}, 31 | code => $is_success, 32 | status => decode("utf8",$status), 33 | }; 34 | my $json = JSON->new->utf8->encode($res); 35 | $responder->([ 36 | 200, 37 | ['Content-Type' => 'text/plain'], 38 | [$json], 39 | ]); 40 | }; 41 | $client->send_message($msg); 42 | }; 43 | 44 | } 45 | 1; 46 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_get_friends_state.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Webqq::Client::Util qw(code2state code2client); 3 | sub Webqq::Client::_get_friends_state { 4 | my $self = shift; 5 | return undef if $self->{type} ne 'smartqq'; 6 | my $ua = $self->{ua}; 7 | my $api_url = 'http://d.web2.qq.com/channel/get_online_buddies2'; 8 | my @headers = ( 9 | Referer=>'http://d.web2.qq.com/proxy.html?v=20130916001&callback=1&id=2' 10 | ); 11 | my @query_string = ( 12 | vfwebqq => $self->{qq_param}{vfwebqq}, 13 | clientid => $self->{qq_param}{clientid}, 14 | psessionid => $self->{qq_param}{psessionid}, 15 | t => time, 16 | ); 17 | my @query_string_pairs; 18 | push @query_string_pairs , shift(@query_string) . "=" . shift(@query_string) while(@query_string); 19 | print "GET $api_url\n" if $self->{debug}; 20 | my $response = $ua->get($api_url.'?'.join("&",@query_string_pairs),@headers); 21 | if($response->is_success){ 22 | print $response->content(),"\n" if $self->{debug}; 23 | my $json = JSON->new->utf8->decode( $response->content() ); 24 | return undef if $json->{retcode} !=0; 25 | for(@{$json->{result}}){ 26 | $_->{client_type} = code2client($_->{client_type}); 27 | $_->{state} = $_->{status}; 28 | delete $_->{status}; 29 | } 30 | return $json->{result}; 31 | } 32 | else{return undef} 33 | } 34 | 1; 35 | -------------------------------------------------------------------------------- /lib/Plack/App/Openqq/SendGroupMessage.pm: -------------------------------------------------------------------------------- 1 | package Plack::App::Openqq::SendGroupMessage; 2 | use parent qw(Plack::Component); 3 | use URI::Escape qw(uri_unescape); 4 | use JSON; 5 | use Encode; 6 | sub call{ 7 | my $self = shift; 8 | my $client = $self->{client}; 9 | my $env = shift; 10 | my %query_string; 11 | for my $query_string (split(/&/,$env->{QUERY_STRING} )){ 12 | my($key,$value) = split /=/,$query_string; 13 | $query_string{$key} = $value; 14 | } 15 | my $uin; 16 | if(defined $query_string{number}){ 17 | $uin = $client->get_uin_from_number($query_string{number}); 18 | } 19 | else{ 20 | $uin = $query_string{uin} || $query_string{gid}; 21 | } 22 | my $content = uri_unescape($query_string{content}); 23 | 24 | return sub { 25 | my $responder = shift; 26 | my $msg = $client->create_group_msg(to_uin=>$uin,content=>$content); 27 | $msg->{cb} = sub{ 28 | my($msg,$is_success,$status) = @_; 29 | my $res = { 30 | msg_id => $msg->{msg_id}, 31 | code => $is_success, 32 | status => decode("utf8",$status), 33 | }; 34 | my $json = JSON->new->utf8->encode($res); 35 | $responder->([ 36 | 200, 37 | ['Content-Type' => 'text/plain'], 38 | [$json], 39 | ]); 40 | }; 41 | $client->send_group_message($msg); 42 | }; 43 | } 44 | 45 | 1; 46 | -------------------------------------------------------------------------------- /Makefile.PL: -------------------------------------------------------------------------------- 1 | use 5.008008; 2 | use ExtUtils::MakeMaker; 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 => 'Webqq::Client', 7 | VERSION_FROM => 'lib/Webqq/Client.pm', # finds $VERSION 8 | DISTNAME => 'Webqq-Client', 9 | LICENSE => "perl", 10 | PREREQ_PM => { 11 | "JSON" => 0, 12 | "AnyEvent::HTTP" => 0, 13 | "LWP::UserAgent" => 0, 14 | "LWP::Protocol::https" => 0, 15 | "Time::Piece" => 0, 16 | "Time::Seconds" => 0, 17 | "Encode::Locale" => 0, 18 | "Webqq::Encryption" => 0, 19 | }, # e.g., Module::Name => 1.1 20 | dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, 21 | clean => { FILES => 'Webqq-Client-* MANIFEST' }, 22 | META_MERGE => { 23 | resources => { 24 | repository=>{ 25 | type => 'git', 26 | url => 'git://github.com/sjdy521/pfqq.git', 27 | web => 'https://github.com/sjdy521/pfqq', 28 | }, 29 | }, 30 | }, 31 | ($] >= 5.005 ? ## Add these new keywords supported since 5.005 32 | ( 33 | #ABSTRACT_FROM => 'lib/Webqq/Client.pm', # retrieve abstract from module 34 | ABSTRACT => 'A webqq client in Perl Language', 35 | AUTHOR => 'sjdy521 ') : ()), 36 | ); 37 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Plugin/HelloGirl.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Plugin::HelloGirl; 2 | use AE; 3 | my @hello = ( 4 | "希望你在群里开心愉快", 5 | "有问题尽管问哦，谁敢欺负你找管理员", 6 | "\@全体成员 请注意，女王发话了", 7 | "妹子一枚，鉴定完毕，大家欢迎呀", 8 | "打劫！打劫！请把你身上所有不懂的问题全部交出来", 9 | ); 10 | my %last; 11 | sub call{ 12 | my ($client,$msg) = @_; 13 | if($msg->{type} eq 'group_message'){ 14 | my $member = $client->search_member_in_group($msg->{group_code},$msg->{send_uin}); 15 | my $gender = $member->{gender} if defined $member; 16 | if($gender eq 'female'){ 17 | my $is_question = $msg->{content}=~/问|帮|怎么/; 18 | my $from_nick; 19 | if($msg->{type} eq 'group_message'){ 20 | $from_nick = $msg->{card} || $msg->from_nick; 21 | } 22 | else{ 23 | $from_nick = $msg->from_nick; 24 | } 25 | 26 | my $from_qq = $msg->from_qq; 27 | if(exists $last{$from_qq} and time - $last{$from_qq} < 3600){ 28 | return 1; 29 | } 30 | $client->reply_message($msg,"\@$from_nick " . $hello[int rand($#hello+1)]); 31 | my $watcher = rand(); 32 | $client->{watchers}{$watcher} = AE::timer 600,0,sub{ 33 | delete $client->{watchers}{$watcher}; 34 | $client->reply_message($msg,"\@$from_nick " . "还需要什么帮助吗"); 35 | } if $is_question; 36 | $last{$from_qq} = time; 37 | return 1; 38 | } 39 | }; 40 | 41 | return 1; 42 | } 43 | 1; 44 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_get_stranger_info.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Encode; 3 | sub Webqq::Client::_get_stranger_info { 4 | my $self = shift; 5 | my $tuin = shift; 6 | return undef if $self->{type} ne 'webqq'; 7 | my $ua = $self->{ua}; 8 | my $cache_data = $self->{cache_for_stranger}->retrieve($tuin); 9 | return $cache_data if defined $cache_data; 10 | my $api_url = 'http://s.web2.qq.com/api/get_stranger_info2'; 11 | my @headers = ( 12 | Referer => 'http://s.web2.qq.com/proxy.html?v=20110412001&callback=1&id=3', 13 | 'Content-Type'=>'utf-8', 14 | ); 15 | my @query_string = ( 16 | tuin => $tuin, 17 | verifysession => undef, 18 | gid => 0, 19 | code => undef, 20 | vfwebqq => $self->{qq_param}{vfwebqq}, 21 | t => time, 22 | ); 23 | 24 | my @query_string_pairs; 25 | push @query_string_pairs , shift(@query_string) . "=" . shift(@query_string) while(@query_string); 26 | my $response = $ua->get($api_url.'?'.join("&",@query_string_pairs),@headers); 27 | 28 | if($response->is_success){ 29 | print $response->content(),"\n" if $self->{debug}; 30 | my $json = JSON->new->utf8->decode($response->content()); 31 | return undef if $json->{retcode}!=0; 32 | $json->{result}{nick} = encode("utf8",$json->{result}{nick}); 33 | $self->{cache_for_stranger}->store($tuin,$json->{result},300); 34 | return $json->{result}; 35 | } 36 | 37 | else{return undef} 38 | } 39 | 1; 40 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/get_single_long_nick.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Encode; 3 | sub Webqq::Client::get_single_long_nick{ 4 | my $self = shift; 5 | my $uin = shift; 6 | 7 | my $cache_data = $self->{cache_for_single_long_nick}->retrieve($uin); 8 | return $cache_data if defined $cache_data; 9 | 10 | my $api_url = 'http://s.web2.qq.com/api/get_single_long_nick2'; 11 | my $ua = $self->{ua}; 12 | my @headers = $self->{type} eq 'webqq'?(Referer=>'http://s.web2.qq.com/proxy.html?v=20110412001&callback=1&id=3') 13 | : (Referer=>'http://s.web2.qq.com/proxy.html?v=20130916001&callback=1&id=1') 14 | ; 15 | my @query_string = ( 16 | tuin => $uin, 17 | vfwebqq => $self->{qq_param}{vfwebqq}, 18 | t => time, 19 | ); 20 | my @query_string_pairs; 21 | push @query_string_pairs , shift(@query_string) . "=" . shift(@query_string) while(@query_string); 22 | my $response = $ua->get($api_url.'?'.join("&",@query_string_pairs),@headers); 23 | if($response->is_success){ 24 | print $response->content(),"\n" if $self->{debug}; 25 | my $json = JSON->new->utf8->decode( $response->content() ); 26 | return undef if $json->{retcode} !=0; 27 | #{"retcode":0,"result":[{"uin":308165330,"lnick":""}]} 28 | my $single_long_nick = encode("utf8",$json->{result}[0]{lnick}); 29 | $self->{cache_for_single_long_nick}->store($uin,$single_long_nick); 30 | return $single_long_nick; 31 | } 32 | else{return undef} 33 | } 34 | 1; 35 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_get_discuss_list_info.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Encode; 3 | sub Webqq::Client::_get_discuss_list_info { 4 | my $self = shift; 5 | my $ua = $self->{ua}; 6 | return undef if $self->{type} ne 'smartqq'; 7 | my $api_url = 'http://s.web2.qq.com/api/get_discus_list'; 8 | my @query_string = ( 9 | clientid => $self->{qq_param}{clientid}, 10 | psessionid => $self->{qq_param}{psessionid}, 11 | vfwebqq => $self->{qq_param}{vfwebqq}, 12 | t => time(), 13 | ); 14 | 15 | my @headers = ( 16 | Referer => 'http://s.web2.qq.com/proxy.html?v=20130916001&callback=1&id=1', 17 | ); 18 | my @query_string_pairs; 19 | push @query_string_pairs , shift(@query_string) . "=" . shift(@query_string) while(@query_string); 20 | my $response = $ua->get($api_url.'?'.join("&",@query_string_pairs),@headers); 21 | if($response->is_success){ 22 | #{"retcode":0,"result":{"dnamelist":[{"name":"测试2","did":2742986730},{"name":"测试","did":3420777698}]}} 23 | print $response->content(),"\n" if $self->{debug}; 24 | my $json; 25 | eval{ 26 | $json = JSON->new->utf8->decode($response->content()) ; 27 | }; 28 | print $@ if $@ and $self->{debug}; 29 | $json = {} unless defined $json; 30 | return undef if $json->{retcode}!=0; 31 | for(@{ $json->{result}{dnamelist} }){ 32 | $_->{name} = encode("utf8",$_->{name}); 33 | } 34 | return $json->{result}{dnamelist}; 35 | 36 | } 37 | else{return undef;} 38 | 39 | } 40 | 41 | 1; 42 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_login2.pm: -------------------------------------------------------------------------------- 1 | use JSON ; 2 | use Webqq::Client::Util qw(console); 3 | sub Webqq::Client::_login2{ 4 | my $self = shift; 5 | console "尝试进行登录(阶段2)...\n"; 6 | my $ua = $self->{ua}; 7 | my $api_url = 'http://d.web2.qq.com/channel/login2'; 8 | my @headers = $self->{type} eq 'webqq'? (Referer=>'http://d.web2.qq.com/proxy.html?v=20110331002&callback=1&id=3') 9 | : (Referer=>'http://d.web2.qq.com/proxy.html?v=20130916001&callback=1&id=2') 10 | ; 11 | my %r = ( 12 | status => $self->{qq_param}{state}, 13 | ptwebqq => $self->{qq_param}{ptwebqq}, 14 | clientid => $self->{qq_param}{clientid}, 15 | psessionid => $self->{qq_param}{psessionid}, 16 | ); 17 | 18 | if($self->{type} eq 'webqq'){ 19 | $r{passwd_sig} = $self->{qq_param}{passwd_sig}; 20 | } 21 | 22 | for(my $i=0;$i<=$self->{ua_retry_times};$i++){ 23 | my $response = $ua->post($api_url,[r=>JSON->new->utf8->encode(\%r)], @headers); 24 | if($response->is_success){ 25 | print $response->content() if $self->{debug}; 26 | my $content = $response->content(); 27 | my $data = JSON->new->utf8->decode($content); 28 | if($data->{retcode} ==0){ 29 | $self->{qq_param}{psessionid} = $data->{result}{psessionid}; 30 | #$self->{qq_param}{vfwebqq} = $data->{result}{vfwebqq}; 31 | $self->_cookie_proxy(); 32 | $self->{login_state} = 'success'; 33 | return 1; 34 | } 35 | } 36 | } 37 | return 0; 38 | } 39 | 1; 40 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_get_group_sig.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | sub Webqq::Client::_get_group_sig { 3 | my $self = shift; 4 | my($id,$to_uin,$service_type,) = @_; 5 | my $cache_data = $self->{cache_for_group_sig}->retrieve("$id|$to_uin|$service_type"); 6 | return $cache_data if defined $cache_data; 7 | my $ua = $self->{ua}; 8 | my $api_url = 'http://d.web2.qq.com/channel/get_c2cmsg_sig2'; 9 | my @query_string = ( 10 | id => $id, 11 | to_uin => $to_uin, 12 | service_type => $service_type, 13 | clientid => $self->{qq_param}{clientid}, 14 | psessionid => $self->{qq_param}{psessionid}, 15 | t => time, 16 | ); 17 | my @headers = $self->{type} eq 'webqq'? (Referer=>'http://d.web2.qq.com/proxy.html?v=20110331002&callback=1&id=3') 18 | : (Referer=>'http://d.web2.qq.com/proxy.html?v=20130916001&callback=1&id=2') 19 | ; 20 | 21 | 22 | my @query_string_pairs; 23 | push @query_string_pairs , shift(@query_string) . "=" . shift(@query_string) while(@query_string); 24 | my $response = $ua->get($api_url.'?'.join("&",@query_string_pairs),@headers); 25 | if($response->is_success){ 26 | print $response->content() if $self->{debug}; 27 | my $json = JSON->new->utf8->decode($response->content()); 28 | return undef if $json->{retcode}!=0; 29 | return undef if $json->{result}{value} eq ""; 30 | $self->{cache_for_group_sig}->store("$id|$to_uin|$service_type",$json->{result}{value},300); 31 | return $json->{result}{value} ; 32 | } 33 | else{return undef} 34 | } 35 | 1; 36 | -------------------------------------------------------------------------------- /lib/Plack/App/Openqq/SendSessMessage.pm: -------------------------------------------------------------------------------- 1 | package Plack::App::Openqq::SendSessMessage; 2 | use parent qw(Plack::Component); 3 | use URI::Escape qw(uri_unescape); 4 | use JSON; 5 | use Encode;; 6 | sub call{ 7 | my $self = shift; 8 | my $client = $self->{client}; 9 | my $env = shift; 10 | my %query_string; 11 | for my $query_string (split(/&/,$env->{QUERY_STRING} )){ 12 | my($key,$value) = split /=/,$query_string; 13 | $query_string{$key} = $value; 14 | } 15 | my $uin; 16 | if(defined $query_string{qq}){ 17 | $uin = $client->get_uin_from_qq($query_string{qq}); 18 | } 19 | else{ 20 | $uin = $query_string{uin}; 21 | } 22 | my $content = uri_unescape($query_string{content}); 23 | my $gid ; 24 | if(defined $query_string{number}){ 25 | $gid = $client->get_uin_from_number($query_string{number}); 26 | } 27 | else{ 28 | $gid = $query_string{gid}; 29 | } 30 | my $did = $query_string{did}; 31 | 32 | return sub { 33 | my $responder = shift; 34 | my $msg = $client->create_sess_msg(to_uin=>$uin,content=>$content,gid=>$gid,did=>$did); 35 | $msg->{cb} = sub{ 36 | my($msg,$is_success,$status) = @_; 37 | my $res = { 38 | msg_id => $msg->{msg_id}, 39 | code => $is_success, 40 | status => decode("utf8",$status), 41 | }; 42 | my $json = JSON->new->utf8->encode($res); 43 | $responder->([ 44 | 200, 45 | ['Content-Type' => 'text/plain'], 46 | [$json], 47 | ]); 48 | }; 49 | $client->send_sess_message($msg); 50 | }; 51 | } 52 | 1; 53 | -------------------------------------------------------------------------------- /README: -------------------------------------------------------------------------------- 1 | Webqq-Client v8.5.3 (该模块已经停止使用和开发 请换用 Mojo::Webqq https://github.com/sjdy521/Mojo-Webqq) 2 | ======================== 3 | 使用Perl语言编写的Webqq客户端，并且可通过插件提供基于HTTP协议的api接口供其他语言或系统调用 4 | 5 | 客户端异步框架 6 | 7 | client 8 | | 9 | ->login() 10 | | 11 | | +-------------------------<------------------------------+ 12 | | | | 13 | |->_recv_message()-[put]-> Webqq::Message::Queue -[get]-> on_receive_message() 14 | | 15 | |->send_message() -[put]--+ +-[get]-> _send_message() ---+ 16 | | \ / | 17 | |->send_sess_message()-[put]-Webqq::Message::Queue-[get]->_send_sess_message()-| 18 | | / \ | 19 | |->send_group_message()-[put]-+ +-[get]->_send_group_message()--| 20 | | | 21 | | on_send_message() ---<---- msg->{cb} -------<-------+ 22 | +->run() 23 | 24 | 安装步骤 25 | 26 | perl Makefile.PL 27 | make 28 | make test 29 | make install 30 | 31 | 推荐使用CPAN安装 32 | 33 | cpan -i Webqq::Client 34 | 35 | 核心依赖模块 36 | 37 | JSON 38 | Encode::Locale 39 | AnyEvent::HTTP 40 | LWP::UserAgent 41 | LWP::Protocol::https 42 | Webqq::Encryption 43 | 44 | 可选模块 45 | 46 | Webqq::Qun 47 | 48 | 版本更新记录 49 | 50 | 请参见 Changes 文件 51 | 52 | COPYRIGHT 和 LICENCE 53 | 54 | Copyright (C) 2014 by sjdy521 55 | 56 | This library is free software; you can redistribute it and/or modify 57 | it under the same terms as Perl itself, either Perl version 5.8.8 or, 58 | at your option, any later version of Perl 5 you may have available. 59 | 60 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_get_user_info.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Webqq::Client::Util qw(code2state code2client); 3 | sub Webqq::Client::_get_user_info{ 4 | my $self = shift; 5 | my $webqq_api_url ='http://s.web2.qq.com/api/get_friend_info2'; 6 | my $smartqq_api_url ='http://s.web2.qq.com/api/get_self_info2'; 7 | my $api_url = $self->{type} eq 'webqq'? $webqq_api_url 8 | : $smartqq_api_url 9 | ; 10 | my $ua = $self->{ua}; 11 | my @headers = $self->{type} eq 'webqq'? (Referer=>'http://s.web2.qq.com/proxy.html?v=20110412001&callback=1&id=3') 12 | : (Referer=>'http://s.web2.qq.com/proxy.html?v=20130916001&callback=1&id=1'); 13 | ; 14 | 15 | my @query_string = ( 16 | t => time, 17 | ); 18 | if($self->{type} eq 'webqq'){ 19 | unshift @query_string,( 20 | tuin => $self->{qq_param}{qq}, 21 | verifysession => undef, 22 | code => undef, 23 | vfwebqq => $self->{qq_param}{vfwebqq}, 24 | vfwebqq => $self->{qq_param}{vfwebqq} 25 | ); 26 | } 27 | my @query_string_pairs; 28 | push @query_string_pairs , shift(@query_string) . "=" . shift(@query_string) while(@query_string); 29 | my $response = $ua->get($api_url.'?'.join("&",@query_string_pairs),@headers); 30 | if($response->is_success){ 31 | print $response->content(),"\n" if $self->{debug}; 32 | my $json = JSON->new->utf8->decode( $response->content() ); 33 | return undef if $json->{retcode} !=0; 34 | $json->{result}{state} = $self->{qq_param}{state}; 35 | $json->{result}{client_type} = 'web'; 36 | return $json->{result}; 37 | } 38 | else{return undef} 39 | } 40 | 1; 41 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_prepare_for_login.pm: -------------------------------------------------------------------------------- 1 | use URI::Escape qw(uri_escape); 2 | use Webqq::Client::Util qw(console); 3 | sub Webqq::Client::_prepare_for_login{ 4 | my $self = shift; 5 | console "初始化 $self->{type} 客户端参数...\n"; 6 | my $ua = $self->{ua}; 7 | my $webqq_api_url = 'https://ui.ptlogin2.qq.com/cgi-bin/login?daid=164&target=self&style=5&mibao_css=m_webqq&appid=1003903&enable_qlogin=0&no_verifyimg=1&s_url=http%3A%2F%2Fweb2.qq.com%2Floginproxy.html&f_url=loginerroralert&strong_login=1&login_state=10&t=20140612002'; 8 | 9 | my $smartqq_api_url = 'https://ui.ptlogin2.qq.com/cgi-bin/login?daid=164&target=self&style=16&mibao_css=m_webqq&appid=501004106&enable_qlogin=0&no_verifyimg=1&s_url=http%3A%2F%2Fw.qq.com%2Fproxy.html&f_url=loginerroralert&strong_login=1&login_state=10&t=20131024001'; 10 | 11 | my $api_url = $self->{type} eq 'webqq'? $webqq_api_url 12 | : $smartqq_api_url 13 | ; 14 | my @headers = $self->{type} eq 'webqq'? (Referer=>'http://web2.qq.com/webqq.html') 15 | : (Referer=>'http://w.qq.com/') 16 | ; 17 | my @global_param = qw( 18 | g_pt_version 19 | g_login_sig 20 | g_style 21 | g_mibao_css 22 | g_daid 23 | g_appid 24 | ); 25 | 26 | my $regex_pattern = 'var\s*(' . join("|",@global_param) . ')\s*=\s*encodeURIComponent\("(.*?)"\)'; 27 | for(my $i=1;$i<=$self->{ua_retry_times};$i++){ 28 | my $response = $ua->get($api_url,@headers); 29 | if($response->is_success){ 30 | my $content = $response->content(); 31 | my %kv = map {uri_escape($_)} $content=~/$regex_pattern/g ; 32 | for(keys %kv){ 33 | $self->{qq_param}{$_} = $kv{$_}; 34 | } 35 | return 1; 36 | } 37 | } 38 | return 0; 39 | } 40 | 1; 41 | -------------------------------------------------------------------------------- /demo/echo.pl: -------------------------------------------------------------------------------- 1 | #一个简单的echo-reply的qq机器人 2 | #你发送什么信息给它，它就回复相同的内容给你 3 | use lib '../lib/'; 4 | use Webqq::Client; 5 | use Digest::MD5 qw(md5_hex); 6 | 7 | my $qq = 12345678 ; 8 | my $pwd = md5_hex('your password'); 9 | my $client = Webqq::Client->new(debug=>0); 10 | $client->login( qq=> $qq, pwd => $pwd); 11 | 12 | 13 | $client->load("ShowMsg"); 14 | #设置全局默认的发送消息后的回调函数，主要用于判断消息是否成功发送 15 | $client->on_send_message = sub{ 16 | my ($msg,$is_success,$status) = @_; 17 | 18 | #使用ShowMsg插件打印发送的消息 19 | $client->call("ShowMsg",$msg); 20 | }; 21 | 22 | #设置接收到消息后的回调函数 23 | $client->on_receive_message = sub{ 24 | #传递给回调的参数是一个包含接收到的消息的hash引用 25 | #$msg = { 26 | # type => message|group_message 消息类型 27 | # msg_id => 系统生成的消息id 28 | # from_uin => 消息发送者uin，回复消息时需要用到 29 | # to_uin => 消息接受者uin，就是自己的qq 30 | # content => 消息内容，采用UTF8编码 31 | # msg_time => 消息的接收时间 32 | # ttl 33 | # msg_class 34 | # allow_plugin 35 | #} 36 | my $msg = shift; 37 | 38 | #使用ShowMsg插件打印接收到的消息 39 | $client->call("ShowMsg",$msg); 40 | 41 | #新的方式 42 | $client->reply_message($msg,$msg->{content}); 43 | 44 | #老的方式，你需要根据消息的类型调用相应的发送消息方法 45 | #if($msg->{type} eq 'message'){ 46 | # $client->send_message( 47 | # to_uin => $msg->{from_uin}, 48 | # content => $msg->{content} , 49 | # ) ; 50 | #} 51 | #elsif($msg->{type} eq 'group_message'){ 52 | # $client->send_group_message( 53 | # to_uin => $msg->{from_uin}, 54 | # content => $msg->{content}, 55 | # ) ; 56 | #} 57 | #elsif($msg->{type} eq 'sess_message'){ 58 | # $client->send_sess_message( 59 | # to_uin => $msg->{from_uin}, 60 | # content => $msg->{content}, 61 | # group_code => $msg->{group_code}, 62 | # ); 63 | #} 64 | }; 65 | $client->run; 66 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/get_qq_from_uin.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Webqq::Client::Util qw(console); 3 | sub Webqq::Client::get_qq_from_uin{ 4 | my $self = shift; 5 | my $uin = shift; 6 | my $cache_data = $self->{cache_for_uin_to_qq}->retrieve($uin); 7 | return $cache_data if defined $cache_data; 8 | my $ua = $self->{ua}; 9 | my $api_url = 'http://s.web2.qq.com/api/get_friend_uin2'; 10 | my @headers = $self->{type} eq 'webqq'? (Referer=>'http://s.web2.qq.com/proxy.html?v=20110412001&callback=1&id=3') 11 | : (Referer=>'http://s.web2.qq.com/proxy.html?v=20130916001&callback=1&id=1') 12 | ; 13 | my @query_string = ( 14 | tuin => $uin, 15 | type => 1, 16 | vfwebqq => $self->{qq_param}{vfwebqq}, 17 | t => time, 18 | ); 19 | 20 | if($self->{type} eq 'webqq'){ 21 | @query_string=( 22 | tuin => $uin, 23 | verifysession => undef, 24 | type => 1, 25 | code => undef, 26 | vfwebqq => $self->{qq_param}{vfwebqq}, 27 | t => time, 28 | ) 29 | } 30 | 31 | my @query_string_pairs; 32 | push @query_string_pairs , shift(@query_string) . "=" . shift(@query_string) while(@query_string); 33 | my $response = $ua->get($api_url.'?'.join("&",@query_string_pairs),@headers); 34 | if($response->is_success){ 35 | print $response->content(),"\n" if $self->{debug}; 36 | my $json = JSON->new->utf8->decode( $response->content() ); 37 | if($json->{retcode} !=0){ 38 | console "从指定uin: $uin 查询QQ号码失败\n"; 39 | return undef; 40 | } 41 | $self->{cache_for_uin_to_qq}->store($uin,$json->{result}{account}); 42 | $self->{cache_for_qq_to_uin}->store($json->{result}{account},$uin); 43 | return $json->{result}{account}; 44 | } 45 | } 46 | 1; 47 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_recv_message.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | sub Webqq::Client::_recv_message{ 3 | my $self = shift; 4 | return if $self->{is_stop}; 5 | my $ua = $self->{asyn_ua}; 6 | my $api_url = ($self->{qq_param}{is_https}?'https':'http') . '://d.web2.qq.com/channel/poll2'; 7 | my $callback = sub { 8 | my $response = shift; 9 | print $response->content() if $self->{debug}; 10 | #分析接收到的消息，并把分析后的消息放到接收消息队列中 11 | $self->parse_receive_msg($response->content()) if $response->is_success; 12 | #重新开始接收消息 13 | my $rand_watcher_id = rand(); 14 | $self->{watchers}{$rand_watcher_id} = AE::timer 2,0,sub{ 15 | delete $self->{watchers}{$rand_watcher_id}; 16 | $self->_recv_message(); 17 | }; 18 | }; 19 | 20 | my %r = ( 21 | clientid => $self->{qq_param}{clientid}, 22 | psessionid => $self->{qq_param}{psessionid}, 23 | key => "", 24 | ); 25 | if($self->{type} eq 'webqq'){ 26 | $r{key} = 0; 27 | $r{ids} = []; 28 | } 29 | my $post_content = [ 30 | r => JSON->new->utf8->encode(\%r), 31 | ]; 32 | if($self->{type} eq 'webqq'){ 33 | push @$post_content,( 34 | clientid => $self->{qq_param}{clientid}, 35 | psessionid => $self->{qq_param}{psessionid} 36 | ); 37 | } 38 | if($self->{debug}){ 39 | require URI; 40 | my $uri = URI->new('http:'); 41 | $uri->query_form($post_content); 42 | print $api_url,"\n"; 43 | print $uri->query(),"\n"; 44 | } 45 | 46 | my @headers = $self->{type} eq 'webqq'? (Referer=>"http://d.web2.qq.com/proxy.html?v=20110331002&callback=1&id=3") 47 | : (Referer=>"http://d.web2.qq.com/proxy.html?v=20130916001&callback=1&id=2") 48 | ; 49 | $ua->post( 50 | $api_url, 51 | $post_content, 52 | @headers, 53 | $callback 54 | ); 55 | 56 | } 57 | 1; 58 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Plugin/PicLimit.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Plugin::PicLimit; 2 | use AE; 3 | use POSIX qw(strftime); 4 | use List::Util qw(first); 5 | my %limit; 6 | my @limit_reply = ( 7 | "警告，请不要频繁发图", 8 | "对不起，本群禁止频繁贴图", 9 | ); 10 | 11 | my @spam_reply = ( 12 | "警告，本群禁止发灌水图", 13 | "请不要灌水", 14 | ); 15 | my $once = 1; 16 | sub call{ 17 | my $client = shift; 18 | my $msg = shift; 19 | my $except_qq = shift; 20 | return if $msg->{type} ne 'group_message'; 21 | 22 | #for(@{$msg->{raw_content}}){ 23 | # next if $_->{type} ne 'cface'; 24 | # if($_->{name}=~/\.gif$/i){ 25 | # my $from_nick = $msg->from_card || $msg->from_nick; 26 | # my $from_qq = $msg->from_qq; 27 | # return if ref $except_qq eq 'ARRAY' and first {$from_qq == $_} @$except_qq ; 28 | # $client->reply_message($msg,"\@$from_nick " . $spam_reply[ int(rand($#spam_reply+1)) ]); 29 | # return; 30 | # } 31 | #}; 32 | 33 | return if $msg->{content} !~ /\[图片\]|\[[^\[\]]+\]\x01/; 34 | my $from_nick = $msg->from_card || $msg->from_nick; 35 | my $from_qq = $msg->from_qq; 36 | return if ref $except_qq eq 'ARRAY' and first {$from_qq == $_} @$except_qq; 37 | #my $group_name = $msg->group_name; 38 | #my $group_code = $msg->group_code; 39 | my $key = strftime("%H",localtime(time)); 40 | $limit{$key}{$msg->{from_uin}}{$from_qq}++; 41 | 42 | my $limit = $limit{$key}{$msg->{from_uin}}{$from_qq}; 43 | 44 | if($limit >= 3 and $limit <=4){ 45 | $client->reply_message($msg,"\@$from_nick " . $limit_reply[ int(rand($#limit_reply+1)) ]); 46 | } 47 | elsif($limit>=5 and $limit <=6){ 48 | $client->reply_message($msg,"\@$from_nick " . "无视警告，请管理员予以禁言惩罚"); 49 | } 50 | elsif($limit>6){ 51 | $client->reply_message($msg,"\@$from_nick " . "大量发图，严重影响群内交流，请管理员将此人踢出"); 52 | } 53 | 54 | if($once){ 55 | $client->{watchers}{rand()} = AE::timer 3600,3600,sub{ 56 | my $key = strftime("%H",localtime(time-3600)); 57 | delete $limit{$key}; 58 | }; 59 | $once = 0; 60 | } 61 | } 62 | 1; 63 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Plugin.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Plugin; 2 | sub new{ 3 | bless { 4 | plugin_num => 0, 5 | plugins => {}, 6 | }; 7 | } 8 | 9 | sub load { 10 | my $self = shift; 11 | my @module_name = @_; 12 | for my $module_name (@module_name){ 13 | my $module_function = undef; 14 | if(substr($module_name,0,1) eq '+'){ 15 | substr($module_name,0,1) = ""; 16 | $module = $module_name; 17 | } 18 | else{ 19 | $module = "Webqq::Client::Plugin::" . $module_name; 20 | } 21 | eval "require $module"; 22 | die "加载插件[ $module ]失败: $@\n" if $@; 23 | $module_function = *{"${module}::call"}{CODE}; 24 | die "加载插件[ $module ]失败: 未获取到call函数引用\n" if ref $module_function ne 'CODE'; 25 | $self->{plugin_num}++; 26 | $self->{plugins}{$module_name} = { 27 | id=>$self->{plugin_num}, 28 | code=>$module_function, 29 | }; 30 | } 31 | } 32 | 33 | sub call_all{ 34 | my $self = shift; 35 | for(sort {$self->{plugins}{$a}{id}<=>$self->{plugins}{$b}{id}} keys %{$self->{plugins}}){ 36 | &{$self->{plugins}{$_}{code}}($self,@_); 37 | } 38 | } 39 | 40 | sub call{ 41 | my $self = shift; 42 | my @plugins; 43 | if(ref $_[0] eq 'ARRAY'){ 44 | @plugins = @{$_[0]}; 45 | shift; 46 | } 47 | else{ 48 | push @plugins,$_[0]; 49 | shift; 50 | } 51 | 52 | for(@plugins){ 53 | if(exists $self->{plugins}{$_}){ 54 | eval { 55 | &{$self->{plugins}{$_}{code}}($self,@_); 56 | }; 57 | print $@,"\n" if $@; 58 | } 59 | else{ 60 | die "运行插件[ $_ ]失败：找不到该插件\n"; 61 | } 62 | } 63 | } 64 | 65 | sub plugin{ 66 | my $self = shift; 67 | my $plugin = shift; 68 | if(exists $self->{plugins}{$plugin}){ 69 | return $self->{plugins}{$plugin}{code}; 70 | } 71 | else{ 72 | die "查找插件[ $_ ]失败：找不到该插件\n"; 73 | } 74 | } 75 | 76 | sub clear { 77 | my $self = shift; 78 | $self->{plugins} = []; 79 | } 80 | 1; 81 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Cron.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Cron; 2 | use AE; 3 | use Webqq::Client::Util qw(console_stderr console); 4 | use POSIX qw(mktime); 5 | use Time::Piece; 6 | use Time::Seconds; 7 | sub add_job{ 8 | my $self = shift; 9 | #AE::now_update; 10 | my($type,$t,$callback) = @_; 11 | if(ref $callback ne 'CODE'){ 12 | console_stderr("Webqq::Client::Cron->add_job()设置的callback无效\n"); 13 | exit; 14 | } 15 | my($hour,$minute) = split /:/,$t; 16 | my $time = {hour => $hour,minute => $minute,second=>0}; 17 | my $delay; 18 | #my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime; 19 | my @now = localtime; 20 | my $now = mktime(@now); 21 | my @next = @{[@now]}; 22 | for my $k (keys %$time){ 23 | $k eq 'year' ? ($next[5]=$time->{$k}-1900) 24 | : $k eq 'month' ? ($next[4]=$time->{$k}-1) 25 | : $k eq 'day' ? ($next[3]=$time->{$k}) 26 | : $k eq 'hour' ? ($next[2]=$time->{$k}) 27 | : $k eq 'minute' ? ($next[1]=$time->{$k}) 28 | : $k eq 'second' ? ($next[0]=$time->{$k}) 29 | : next; 30 | } 31 | 32 | my $next = mktime(@next); 33 | $now = localtime($now); 34 | $next = localtime($next); 35 | 36 | if($now >= $next){ 37 | if( $time->{month} ) { 38 | $next->add_years(1); 39 | } 40 | elsif( $time->{day} ) { 41 | $next->add_months(1); 42 | } 43 | elsif( $time->{hour} ) { 44 | $next += ONE_DAY; 45 | } 46 | elsif( $time->{minute} ) { 47 | $next += ONE_HOUR; 48 | } 49 | elsif( $time->{second} ) { 50 | $next += ONE_MINUTE; 51 | } 52 | } 53 | 54 | console "[$type]下一次触发时间为：" . $next->strftime("%Y/%m/%d %H:%M:%S\n") if $self->{debug}; 55 | $delay = $next - $now; 56 | my $rand_watcher_id = rand(); 57 | $self->{watchers}{$rand_watcher_id} = AE::timer $delay,0,sub{ 58 | delete $self->{watchers}{$rand_watcher_id}; 59 | eval{ 60 | $callback->(); 61 | }; 62 | console $@ if $@; 63 | $self->add_job($type,$t,$callback); 64 | }; 65 | } 66 | 1; 67 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_get_offpic.pm: -------------------------------------------------------------------------------- 1 | use strict; 2 | use File::Temp qw/:seekable/; 3 | use Webqq::Client::Util qw(console); 4 | sub Webqq::Client::_get_offpic { 5 | my $self = shift; 6 | return if $self->{type} ne 'smartqq'; 7 | my $file_path = shift; 8 | my $from_uin = shift; 9 | my $cb = shift; 10 | my $api = 'http://w.qq.com/d/channel/get_offpic2'; 11 | if(ref $cb eq 'CODE'){ 12 | my @query_string = ( 13 | file_path => $file_path, 14 | f_uin => $from_uin, 15 | clientid => $self->{qq_param}{clientid}, 16 | psessionid => $self->{qq_param}{psessionid}, 17 | ); 18 | my $callback = sub{ 19 | my $response = shift; 20 | if($response->is_success){ 21 | return unless $response->header("content-type") =~/^image\/(.*)/; 22 | my $type = $1=~/jpe?g/i ? ".jpg" 23 | : $1=~/png/i ? ".png" 24 | : $1=~/bmp/i ? ".bmp" 25 | : $1=~/gif/i ? ".gif" 26 | : undef 27 | ; 28 | return unless defined $type; 29 | my $tmp = File::Temp->new( 30 | TEMPLATE => "webqq_offpic_XXXX", 31 | SUFFIX => $type, 32 | TMPDIR => 1, 33 | UNLINK => 1, 34 | ); 35 | binmode $tmp; 36 | print $tmp $response->content(); 37 | close $tmp; 38 | eval{ 39 | open(my $fh,"<:raw",$tmp->filename) or die $!; 40 | $cb->($fh,$tmp->filename); 41 | close $fh; 42 | }; 43 | console "[Webqq::Client::_get_offpic] $@" if $@; 44 | } 45 | }; 46 | require URI; 47 | my $uri = URI->new('http:'); 48 | $uri->query_form(\@query_string); 49 | print "GET $api?" . $uri->query() . "\n" if $self->{debug}; 50 | $self->{asyn_ua}->get($api ."?". $uri->query(),$callback); 51 | } 52 | }; 53 | 1; 54 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_get_friend_info.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Webqq::Client::Util qw(code2state); 3 | sub Webqq::Client::_get_friend_info{ 4 | my $self = shift; 5 | my $uin = shift; 6 | my $api_url = 'http://s.web2.qq.com/api/get_friend_info2'; 7 | my $ua = $self->{ua}; 8 | my @headers = $self->{type} eq 'webqq'? (Referer=>'http://s.web2.qq.com/proxy.html?v=20110412001&callback=1&id=3') 9 | : (Referer=>'http://s.web2.qq.com/proxy.html?v=20130916001&callback=1&id=1') 10 | ; 11 | my @query_string = ( 12 | tuin => $uin, 13 | vfwebqq => $self->{qq_param}{vfwebqq}, 14 | clientid => $self->{qq_param}{clientid}, 15 | psessionid => $self->{qq_param}{psessionid}, 16 | t => time, 17 | ); 18 | 19 | if($self->{type} eq 'webqq'){ 20 | @query_string = ( 21 | tuin => $uin, 22 | verifysession => undef, 23 | code => undef, 24 | vfwebqq => $self->{qq_param}{vfwebqq}, 25 | t => time, 26 | ); 27 | } 28 | my @query_string_pairs; 29 | push @query_string_pairs , shift(@query_string) . "=" . shift(@query_string) while(@query_string); 30 | my $response = $ua->get($api_url.'?'.join("&",@query_string_pairs),@headers); 31 | if($response->is_success){ 32 | print $response->content(),"\n" if $self->{debug}; 33 | my $json = JSON->new->utf8->decode( $response->content() ); 34 | return undef if $json->{retcode} !=0; 35 | my $user_info = $json->{result}; 36 | for my $key (keys %{ $user_info }){ 37 | if($key eq 'birthday'){ 38 | $user_info->{$key} = 39 | encode("utf8", join("-",@{ $user_info->{birthday}}{qw(year month day)} ) ); 40 | } 41 | elsif($key eq 'stat'){ 42 | $user_info{state} = code2state($user_info->{'stat'}); 43 | } 44 | else{ 45 | $user_info->{$key} = encode("utf8",$user_info->{$key}); 46 | } 47 | } 48 | delete $user_info->{'stat'}; 49 | return $user_info; 50 | } 51 | else{return undef} 52 | } 53 | 1; 54 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_relink.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Webqq::Client::Util qw(console); 3 | sub Webqq::Client::_relink{ 4 | my $self = shift; 5 | $self->{login_state} = 'relink'; 6 | console "正在进行重新连接...\n"; 7 | my $ua = $self->{ua}; 8 | my $api_url = 'http://d.web2.qq.com/channel/login2'; 9 | my @headers = $self->{type} eq 'webqq'? (Referer=>'http://d.web2.qq.com/proxy.html?v=20110331002&callback=1&id=3') 10 | : (Referer=>'http://d.web2.qq.com/proxy.html?v=20130916001&callback=1&id=2') 11 | ; 12 | my %r = ( 13 | status => $self->{qq_param}{status}, 14 | key => "", 15 | ptwebqq => $self->{qq_param}{ptwebqq}, 16 | clientid => $self->{qq_param}{clientid}, 17 | psessionid => $self->{qq_param}{psessionid}, 18 | ); 19 | 20 | if($self->{type} eq 'webqq'){ 21 | $r{passwd_sig} = $self->{qq_param}{passwd_sig}; 22 | } 23 | 24 | for(my $i=0;$i<=$self->{ua_retry_times};$i++){ 25 | my $response = $ua->post($api_url,[r=>JSON->new->utf8->encode(\%r)], @headers); 26 | if($response->is_success){ 27 | print $response->content() if $self->{debug}; 28 | my $content = $response->content(); 29 | my $data = JSON->new->utf8->decode($content); 30 | if($data->{retcode} ==0){ 31 | $self->{qq_param}{psessionid} = $data->{result}{psessionid} if $data->{result}{psessionid}; 32 | $self->{qq_param}{vfwebqq} = $data->{result}{vfwebqq} if $data->{result}{vfwebqq}; 33 | $self->{qq_param}{clientid} = $data->{result}{clientid} if $data->{result}{clientid}; 34 | $self->{qq_param}{ptwebqq} = $data->{result}{ptwebqq} if $data->{result}{ptwebqq}; 35 | $self->{qq_param}{skey} = $data->{result}{skey} if $data->{result}{skey}; 36 | $self->{cookie_jar}->set_cookie(0,"ptwebqq",$data->{result}{ptwebqq},"/","qq.com"); 37 | $self->_cookie_proxy(); 38 | $self->{login_state} = 'success'; 39 | return 1; 40 | } 41 | else{ 42 | $self->relogin(); 43 | return 0; 44 | } 45 | } 46 | } 47 | $self->relogin(); 48 | return 0; 49 | } 50 | 1; 51 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_send_discuss_message.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Encode; 3 | use Storable qw(dclone); 4 | sub Webqq::Client::_send_discuss_message { 5 | my $self = shift; 6 | return if $self->{type} ne 'smartqq'; 7 | my $msg = shift; 8 | my $ua = $self->{asyn_ua}; 9 | my $api_url = ($self->{is_https}?'https':'http') . '://d.web2.qq.com/channel/send_discu_msg2'; 10 | 11 | my $callback = sub{ 12 | my $response = shift; 13 | print $response->content(),"\n" if $self->{debug}; 14 | my $status = $self->parse_send_status_msg( $response->content() ); 15 | if(defined $status and $status->{is_success} == 0){ 16 | $self->send_discuss_message($msg); 17 | return; 18 | } 19 | elsif(defined $status){ 20 | if(ref $msg->{cb} eq 'CODE'){ 21 | $msg->{cb}->( 22 | $msg, #msg 23 | $status->{is_success}, #is_success 24 | $status->{status} #status 25 | ); 26 | } 27 | if(ref $self->{on_send_message} eq 'CODE'){ 28 | $self->{on_send_message}->( 29 | $msg, #msg 30 | $status->{is_success}, #is_success 31 | $status->{status} #status 32 | ); 33 | } 34 | } 35 | }; 36 | 37 | my @headers = ( 38 | Referer => 'http://d.web2.qq.com/proxy.html?v=20130916001&callback=1&id=2', 39 | ); 40 | my $content = [decode("utf8",$msg->{content}),"",[]]; 41 | my %s = ( 42 | did => $msg->{did} || $msg->{to_uin}, 43 | face => $self->{qq_database}{user}{face} || 591, 44 | content => JSON->new->utf8->encode($content), 45 | msg_id => $msg->{msg_id}, 46 | clientid => $self->{qq_param}{clientid}, 47 | psessionid => $self->{qq_param}{psessionid}, 48 | ); 49 | $s{content} = decode("utf8",$s{content}); 50 | my $post_content = [ 51 | r => JSON->new->utf8->encode(\%s), 52 | ]; 53 | 54 | if($self->{debug}){ 55 | require URI; 56 | my $uri = URI->new('http:'); 57 | $uri->query_form($post_content); 58 | print $api_url,"\n"; 59 | print $uri->query(),"\n"; 60 | } 61 | 62 | $ua->post( 63 | $api_url, 64 | $post_content, 65 | @headers, 66 | $callback, 67 | ); 68 | 69 | } 70 | 1; 71 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_get_img_verify_code.pm: -------------------------------------------------------------------------------- 1 | use File::Temp qw/tempfile/; 2 | use Webqq::Client::Util qw(console); 3 | sub Webqq::Client::_get_img_verify_code{ 4 | my $self = shift; 5 | if ($self->{qq_param}{is_need_img_verifycode} == 0){ 6 | $self->{qq_param}{img_verifycode_source} = 'NONE'; 7 | return 1 ; 8 | } 9 | my $ua = $self->{ua}; 10 | my $api_url = 'https://ssl.captcha.qq.com/getimage'; 11 | my @headers = $self->{type} eq 'webqq'? (Referer => 'https://ui.ptlogin2.qq.com/cgi-bin/login?daid=164&target=self&style=5&mibao_css=m_webqq&appid=1003903&enable_qlogin=0&no_verifyimg=1&s_url=http%3A%2F%2Fweb2.qq.com%2Floginproxy.html&f_url=loginerroralert&strong_login=1&login_state=10&t=20140612002') 12 | : (Referer => 'https://ui.ptlogin2.qq.com/cgi-bin/login?daid=164&target=self&style=16&mibao_css=m_webqq&appid=501004106&enable_qlogin=0&no_verifyimg=1&s_url=http%3A%2F%2Fw.qq.com%2Fproxy.html&f_url=loginerroralert&strong_login=1&login_state=10&t=20131024001') 13 | ; 14 | my @query_string = ( 15 | aid => $self->{qq_param}{g_appid}, 16 | r => rand(), 17 | uin => $self->{qq_param}{qq}, 18 | cap_cd => $self->{qq_param}{cap_cd}, 19 | ); 20 | 21 | my @query_string_pairs; 22 | push @query_string_pairs , shift(@query_string) . "=" . shift(@query_string) while(@query_string) ; 23 | 24 | for(my $i=1;$i<=$self->{ua_retry_times};$i++){ 25 | my $response = $ua->get($api_url.'?'.join("&",@query_string_pairs),@headers); 26 | if($response->is_success){ 27 | my ($fh, $filename) = tempfile("webqq_img_verfiy_XXXX",SUFFIX =>".jpg",TMPDIR => 1); 28 | binmode $fh; 29 | print $fh $response->content(); 30 | close $fh; 31 | if(-t STDIN){ 32 | console "请输入图片验证码 [ $filename ]: "; 33 | chomp($self->{qq_param}{verifycode} = ); 34 | $self->{qq_param}{img_verifycode_source} = 'TTY'; 35 | } 36 | elsif(ref $self->{on_input_img_verifycode} eq 'CODE'){ 37 | my $code = $self->{on_input_img_verifycode}->($filename); 38 | if(defined $code){ 39 | $self->{qq_param}{verifycode} = $code; 40 | $self->{qq_param}{img_verifycode_source} = 'CALLBACK'; 41 | } 42 | else{console "无法从回调函数中获取有效的验证码，客户端终止\n";$self->stop();} 43 | } 44 | else{ 45 | console "STDIN未连接到tty，无法输入验证码，客户端终止...\n"; 46 | $self->stop(); 47 | } 48 | return 1; 49 | } 50 | } 51 | return 0; 52 | } 53 | 1; 54 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_send_group_message.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Encode; 3 | use Storable qw(dclone); 4 | sub Webqq::Client::_send_group_message{ 5 | my($self,$msg) = @_; 6 | #将整个hash从UTF8还原回uincode编码 7 | my $ua = $self->{asyn_ua}; 8 | 9 | my $callback = sub{ 10 | my $response = shift; 11 | print $response->content() if $self->{debug}; 12 | my $status = $self->parse_send_status_msg( $response->content() ); 13 | if(defined $status and $status->{is_success} ==0){ 14 | $self->send_group_message($msg); 15 | return; 16 | } 17 | elsif(defined $status){ 18 | if(ref $msg->{cb} eq 'CODE'){ 19 | $msg->{cb}->( 20 | $msg, #msg 21 | $status->{is_success}, #is_success 22 | $status->{status} #status 23 | ); 24 | } 25 | if(ref $self->{on_send_message} eq 'CODE'){ 26 | $self->{on_send_message}->( 27 | $msg, #msg 28 | $status->{is_success}, #is_success 29 | $status->{status} #status 30 | ); 31 | } 32 | } 33 | }; 34 | 35 | my $api_url = ($self->{qq_param}{is_https}?'https':'http') . '://d.web2.qq.com/channel/send_qun_msg2'; 36 | my @headers = $self->{type} eq 'webqq'? (Referer =>'http://d.web2.qq.com/proxy.html?v=20110331002&callback=1&id=3') 37 | : (Referer =>'http://d.web2.qq.com/proxy.html?v=20130916001&callback=1&id=2') 38 | ; 39 | my $content = [decode("utf8",$msg->{content}),[]]; 40 | my %s = ( 41 | group_uin => $msg->{to_uin}, 42 | content => JSON->new->utf8->encode($content), 43 | msg_id => $msg->{msg_id}, 44 | clientid => $self->{qq_param}{clientid}, 45 | psessionid => $self->{qq_param}{psessionid}, 46 | ); 47 | $s{content} = decode("utf8",$s{content}); 48 | if($self->{type} eq 'smartqq'){ 49 | $s{face} = $self->{qq_database}{user}{face} || "591"; 50 | } 51 | my $post_content = [ 52 | r => JSON->new->utf8->encode(\%s), 53 | ]; 54 | if($self->{type} eq 'webqq'){ 55 | push @$post_content,( 56 | clientid => $self->{qq_param}{clientid}, 57 | psessionid => $self->{qq_param}{psessionid} 58 | ); 59 | } 60 | if($self->{debug}){ 61 | require URI; 62 | my $uri = URI->new('http:'); 63 | $uri->query_form($post_content); 64 | print $api_url,"\n"; 65 | print $uri->query(),"\n"; 66 | } 67 | 68 | $ua->post( 69 | $api_url, 70 | $post_content, 71 | @headers, 72 | $callback, 73 | ); 74 | } 75 | 1; 76 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_send_message.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Encode; 3 | use Storable qw(dclone); 4 | sub Webqq::Client::_send_message{ 5 | my($self,$msg) = @_; 6 | #将整个hash从UTF8还原为unicode 7 | my $ua = $self->{asyn_ua}; 8 | my $callback = sub{ 9 | my $response = shift; 10 | print $response->content() if $self->{debug}; 11 | my $status = $self->parse_send_status_msg( $response->content() ); 12 | if(defined $status and $status->{is_success} == 0){ 13 | $self->send_message($msg); 14 | return; 15 | } 16 | elsif(defined $status){ 17 | if(ref $msg->{cb} eq 'CODE'){ 18 | $msg->{cb}->( 19 | $msg, #msg 20 | $status->{is_success}, #is_success 21 | $status->{status} #status 22 | ); 23 | } 24 | if(ref $self->{on_send_message} eq 'CODE'){ 25 | $self->{on_send_message}->( 26 | $msg, #msg 27 | $status->{is_success}, #is_success 28 | $status->{status} #status 29 | ); 30 | } 31 | } 32 | }; 33 | my $api_url = ($self->{qq_param}{is_https}?'https':'http') . '://d.web2.qq.com/channel/send_buddy_msg2'; 34 | my @headers = $self->{type} eq 'webqq'? (Referer=>'http://d.web2.qq.com/proxy.html?v=20110331002&callback=1&id=3') 35 | : (Referer=>'http://d.web2.qq.com/proxy.html?v=20130916001&callback=1&id=2') 36 | ; 37 | my $content = [decode("utf8",$msg->{content}),"",[]]; 38 | my %s = ( 39 | to => $msg->{to_uin}, 40 | face => $self->{qq_database}{user}{face} || 570, 41 | content => JSON->new->utf8->encode($content), 42 | msg_id => $msg->{msg_id}, 43 | clientid => $self->{qq_param}{clientid}, 44 | psessionid => $self->{qq_param}{psessionid}, 45 | ); 46 | $s{content} = decode("utf8",$s{content}); 47 | 48 | if($self->{type} eq 'smartqq'){ 49 | $s{face} = $self->{qq_database}{user}{face} || "591"; 50 | } 51 | my $post_content = [ 52 | r => JSON->new->utf8->encode(\%s), 53 | ]; 54 | if($self->{type} eq 'webqq'){ 55 | push @$post_content,( 56 | clientid => $self->{qq_param}{clientid}, 57 | psessionid => $self->{qq_param}{psessionid} 58 | ); 59 | } 60 | if($self->{debug}){ 61 | require URI; 62 | my $uri = URI->new('http:'); 63 | $uri->query_form($post_content); 64 | print $api_url,"\n"; 65 | print $uri->query(),"\n"; 66 | } 67 | $ua->post( 68 | $api_url, 69 | $post_content, 70 | @headers, 71 | $callback, 72 | ); 73 | } 74 | 1; 75 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_send_sess_message.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Encode; 3 | sub Webqq::Client::_send_sess_message{ 4 | my($self,$msg) = @_; 5 | return unless defined $msg->{group_sig}; 6 | my $ua = $self->{asyn_ua}; 7 | my $callback = sub{ 8 | my $response = shift; 9 | print $response->content() if $self->{debug}; 10 | my $status = $self->parse_send_status_msg( $response->content() ); 11 | if(defined $status and $status->{is_success}==0){ 12 | $self->send_sess_message($msg); 13 | return; 14 | } 15 | elsif(defined $status){ 16 | if(ref $msg->{cb} eq 'CODE'){ 17 | $msg->{cb}->( 18 | $msg, #msg 19 | $status->{is_success}, #is_success 20 | $status->{status} #status 21 | ); 22 | } 23 | if(ref $self->{on_send_message} eq 'CODE'){ 24 | $self->{on_send_message}->( 25 | $msg, #msg 26 | $status->{is_success}, #is_success 27 | $status->{status} #status 28 | ); 29 | } 30 | } 31 | }; 32 | 33 | my $api_url = ($self->{is_https}?'https':'http') . '://d.web2.qq.com/channel/send_sess_msg2'; 34 | my @headers = $self->{type} eq 'webqq'? (Referer => 'http://d.web2.qq.com/proxy.html?v=20110331002&callback=1&id=3') 35 | : (Referer => 'http://d.web2.qq.com/proxy.html?v=20130916001&callback=1&id=2') 36 | ; 37 | my $content = [decode("utf8",$msg->{content}),[]]; 38 | my %s = ( 39 | to => $msg->{to_uin}, 40 | group_sig => $msg->{group_sig}, 41 | face => $self->{qq_database}{user}{face} || 591, 42 | content => JSON->new->utf8->encode($content), 43 | msg_id => $msg->{msg_id}, 44 | service_type => $msg->{service_type}, 45 | clientid => $self->{qq_param}{clientid}, 46 | psessionid => $self->{qq_param}{psessionid}, 47 | ); 48 | $s{content} = decode("utf8",$s{content}); 49 | my $post_content = [ 50 | r => JSON->new->utf8->encode(\%s), 51 | ]; 52 | 53 | if($self->{type} eq 'webqq'){ 54 | push @$post_content,( 55 | clientid => $self->{qq_param}{clientid}, 56 | psessionid => $self->{qq_param}{psessionid}, 57 | ); 58 | } 59 | 60 | if($self->{debug}){ 61 | require URI; 62 | my $uri = URI->new('http:'); 63 | $uri->query_form($post_content); 64 | print $api_url,"\n"; 65 | print $uri->query(),"\n"; 66 | } 67 | 68 | $ua->post( 69 | $api_url, 70 | $post_content, 71 | @headers, 72 | $callback, 73 | ); 74 | } 75 | 1; 76 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Plugin/Openqq.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Plugin::Openqq; 2 | use Plack::App::URLMap; 3 | use Plack::App::robots; 4 | use Plack::Builder; 5 | use Plack::App::Openqq::SendMessage; 6 | use Plack::App::Openqq::SendGroupMessage; 7 | use Plack::App::Openqq::SendSessMessage; 8 | use Plack::App::Openqq::SendDiscussMessage; 9 | use Plack::App::Openqq::GetUserInfo; 10 | use Plack::App::Openqq::GetFriendInfo; 11 | use Plack::App::Openqq::GetGroupInfo; 12 | use Plack::App::Openqq::GetDiscussInfo; 13 | use Plack::App::Openqq::GetRecentInfo; 14 | use Plack::Middleware::Openqq::SelfTalkForbid; 15 | use Twiggy::Server; 16 | my $server; 17 | sub call{ 18 | my $client = shift; 19 | my $new = {client => $client}; 20 | my %p = @_; 21 | my $host = $p{host} || '0.0.0.0'; 22 | my $port = $p{port} || 5000; 23 | my $app = 24 | builder { 25 | enable "Header",set => ['Server',"Openqq-Server-$client->{client_version}"]; 26 | enable "Openqq::SelfTalkForbid",client=>$client; 27 | builder{ 28 | #mount "//" => builder { 29 | # 30 | #}; 31 | mount "/openqq/get_user_info" => builder { 32 | Plack::App::Openqq::GetUserInfo->new($new)->to_app; 33 | }; 34 | mount "/openqq/get_friend_info" => builder { 35 | Plack::App::Openqq::GetFriendInfo->new($new)->to_app; 36 | }; 37 | mount "/openqq/get_group_info" => builder { 38 | Plack::App::Openqq::GetGroupInfo->new($new)->to_app; 39 | }; 40 | mount "/openqq/get_discuss_info" => builder { 41 | Plack::App::Openqq::GetDiscussInfo->new($new)->to_app; 42 | }; 43 | mount "/openqq/get_recent_info" => builder { 44 | Plack::App::Openqq::GetRecentInfo->new($new)->to_app; 45 | }; 46 | mount "/openqq/send_message" => builder { 47 | Plack::App::Openqq::SendMessage->new($new)->to_app; 48 | }; 49 | mount "/openqq/send_group_message" => builder { 50 | Plack::App::Openqq::SendGroupMessage->new($new)->to_app; 51 | }; 52 | mount "/openqq/send_discuss_message" => builder { 53 | Plack::App::Openqq::SendDiscussMessage->new($new)->to_app; 54 | }; 55 | mount "/openqq/send_sess_message" => builder { 56 | Plack::App::Openqq::SendSessMessage->new($new)->to_app; 57 | }; 58 | mount "/robots.txt" => builder { 59 | enable "Header",set => ['Cache-Control','max-age=31536000']; 60 | Plack::App::robots->new->to_app; 61 | }; 62 | }; 63 | }; 64 | $server = Twiggy::Server->new( 65 | host => $host, 66 | port => $port, 67 | ); 68 | return unless defined $server; 69 | $server->register_service($app); 70 | } 71 | 1; 72 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Plugin/IrcSync.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Plugin::IrcSync; 2 | use AnyEvent::IRC::Client; 3 | use List::Util qw(first); 4 | my $irc = new AnyEvent::IRC::Client; 5 | my $once = 1; 6 | my $join = 0; 7 | sub call { 8 | my $client = shift; 9 | my $msg = shift; 10 | my %p = @_; 11 | 12 | my $channel = $p{channel} || "#ChinaPerl"; 13 | return 1 if $msg->{type} ne "group_message"; 14 | my $debug = $client->{debug}; 15 | 16 | if ($once) { 17 | my $server = $p{server} || "irc.freenode.net"; 18 | my $port = $p{port} || 6667; 19 | my $nick = $p{nick} or die "[Webqq::Client::Plugin::IrcSync] nick must be set\n"; 20 | my $user = $p{user}; 21 | my $real = $p{real}; 22 | my $password = $p{password}; 23 | $irc->reg_cb( 24 | registered => sub { print "[Webqq::Client::Plugin::IrcSync] $nick has registered $server:$port\n" if $debug;}, 25 | join => sub { 26 | print "[Webqq::Client::Plugin::IRC] $nick has joined $channel\n" if $debug; 27 | $join = 1; 28 | }, 29 | publicmsg => sub { 30 | my($self,$channel, $ircmsg) = @_; 31 | my $sender_nick = substr($ircmsg->{prefix},0,index($ircmsg->{prefix},"!~")) || "UnknownNick"; 32 | my $msg_content = $ircmsg->{params}[1]; 33 | return if $ircmsg->{command} ne "PRIVMSG"; 34 | return if $msg_content =~/^[~ ]/; 35 | #if($client->{debug}){ 36 | # print "[Webqq::Client::Plugin::IrcSync] \@$sender_nick (in $channel) say: $msg_content\n"; 37 | #} 38 | my $group = first {$_->{name} eq $p{group_name}} @{$client->{qq_database}{group_list}} or return ; 39 | $client->send_group_message( 40 | to_uin => $group->{gid}, 41 | content => "[${sender_nick}#irc] " . $msg_content 42 | ); 43 | }, 44 | disconnect => sub { print "[Webqq::Client::Plugin::IrcSync] $nick has quit $server:$port\n" if $debug;}, 45 | ); 46 | $irc->send_srv(JOIN => $channel); 47 | $irc->connect($server,$port,{nick=>$nick,user=>$user,real=>$real,password=>$password}); 48 | $once = 0; 49 | } 50 | return 1 unless $join; 51 | return 1 if ($msg->{msg_class} eq "send" and $msg->{content}=~/^\[.*#irc\]/); 52 | my $group_name = $msg->group_name; 53 | return 1 if $p{group_name} ne $group_name; 54 | my $msg_sender_nick = $msg->from_nick; 55 | my $msg_sender_card = $msg->from_card if $msg->{msg_class} eq 'recv'; 56 | my $msg_sender = $msg_sender_card || $msg_sender_nick; 57 | $msg_sender = "昵称未知" unless defined $msg_sender; 58 | $msg_sender = $client->{qq_database}{user}{nick} if $msg_sender eq "我"; 59 | for(split /\n/,$msg->{content}){ 60 | $irc->send_msg(PRIVMSG => $channel, "[\@$msg_sender] ". $_); 61 | } 62 | } 63 | 1; 64 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Plugin/SendMsgFromSocket.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Plugin::SendMsgFromSocket; 2 | use Webqq::Client::Util qw(console); 3 | use AnyEvent::Socket; 4 | use AnyEvent::Handle; 5 | my %connection; 6 | sub call{ 7 | my $client = shift; 8 | tcp_server "127.0.0.1", 2014, sub { 9 | my($fh,$host,$port) = @_; 10 | my $client_id = rand(); 11 | $connection{$client_id}[0] = $fh; 12 | my $hdl; $hdl = AnyEvent::Handle->new( 13 | fh => $fh , 14 | on_error => sub { 15 | my ($hdl, $fatal, $msg) = @_; 16 | $hdl->destroy; 17 | delete $client{$client_id}; 18 | }, 19 | ); 20 | $connection{$client_id}[1] = $hdl; 21 | $hdl->push_read (line => sub { 22 | my ($hdl, $line) = @_; 23 | delete $connection{$client_id}; 24 | console "从socket接收到发送消息指令: $line\n"; 25 | my($type,$uin,$content) = split(/\s+/,$line,3); 26 | if($type eq 'group'){ 27 | my $gcode = $client->get_group_code_from_gid($uin); 28 | unless(defined $gcode){ 29 | console "指定的群不存在,指令无效: $line\n"; 30 | return; 31 | } 32 | $client->send_group_message(to_uin=>$uin,content=>$content); 33 | } 34 | elsif($type eq 'friend'){ 35 | my $f = $client->search_friend($uin); 36 | unless(defined $f){ 37 | console "指定的好友不存在,指令无效: $line\n"; 38 | return; 39 | } 40 | $client->send_message(to_uin=>$uin,content=>$content); 41 | } 42 | elsif($type eq 'discuss'){ 43 | my $d = $client->search_discuss($uin); 44 | unless(defined $d){ 45 | console "指定的讨论组不存在,指令无效: $line\n"; 46 | return; 47 | } 48 | $client->send_discuss_message(to_uin=>$uin,content=>$content); 49 | } 50 | elsif($type eq 'group_sess'){ 51 | my($to_uin,$gid) = split /:/,$uin,2; 52 | my $gcode = $client->get_group_code_from_gid($gid); 53 | my $m = $client->search_member_in_group($gcode,$to_uin); 54 | unless(defined $m){ 55 | console "指定的群或群成员不存在,指令无效: $line\n"; 56 | return; 57 | } 58 | $client->send_sess_message(to_uin=>$to_uin,content=>$content,gid=>$gid); 59 | } 60 | elsif($type eq 'discuss_sess'){ 61 | my($to_uin,$did) = split /:/,$uin,2; 62 | my $m = $client->search_member_in_discuss($did,$to_uin); 63 | unless(defined $m){ 64 | console "指定的讨论组或讨论组成员不存在,指令无效: $line\n"; 65 | return; 66 | } 67 | $client->send_sess_message(to_uin=>$to_uin,content=>$content,did=>$did); 68 | } 69 | }); 70 | 71 | }; 72 | } 73 | 74 | 75 | 1; 76 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_get_user_friends.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Webqq::Client::Util qw(hash); 3 | sub Webqq::Client::_get_user_friends{ 4 | my $self = shift; 5 | my $api_url = 'http://s.web2.qq.com/api/get_user_friends2'; 6 | my $ua = $self->{ua}; 7 | my @headers = $self->{type} eq 'webqq'? (Referer=>'http://s.web2.qq.com/proxy.html?v=20110412001&callback=1&id=3') 8 | : (Referer=>'http://s.web2.qq.com/proxy.html?v=20130916001&callback=1&id=1') 9 | ; 10 | my %r = ( 11 | hash => hash($self->{qq_param}{ptwebqq},$self->{qq_param}{qq}), 12 | vfwebqq => $self->{qq_param}{vfwebqq}, 13 | ); 14 | if($self->{type} eq 'webqq'){ 15 | $r{"h"} = "hello"; 16 | } 17 | my $response = $ua->post($api_url,[r=>JSON->new->utf8->encode(\%r)],@headers); 18 | if($response->is_success){ 19 | print $response->content(),"\n" if $self->{debug}; 20 | my $json = JSON->new->utf8->decode($response->content()); 21 | return undef if $json->{retcode}!=0 ; 22 | my $friends_state = $self->_get_friends_state(); 23 | my %categories ; 24 | my %info; 25 | my %marknames; 26 | my %vipinfo; 27 | my %state; 28 | if(defined $friends_state){ 29 | for(@{$friends_state}){ 30 | $state{$_->{uin}}{state} = $_->{state}; 31 | $state{$_->{uin}}{client_type} = $_->{client_type}; 32 | } 33 | } 34 | for(@{ $json->{result}{categories}}){ 35 | $categories{ $_->{'index'} } = {'sort'=>$_->{'sort'},name=>encode("utf8",$_->{name}) }; 36 | } 37 | $categories{0} = {sort=>0,name=>'我的好友'}; 38 | for(@{ $json->{result}{info}}){ 39 | $info{$_->{uin}} = {face=>$_->{face},flag=>$_->{flag},nick=>encode("utf8",$_->{nick}),}; 40 | } 41 | for(@{ $json->{result}{marknames} }){ 42 | $marknames{$_->{uin}} = {markname=>encode("utf8",$_->{markname}),type=>$_->{type}}; 43 | } 44 | for(@{ $json->{result}{vipinfo} }){ 45 | $vipinfo{$_->{u}} = {vip_level=>$_->{vip_level},is_vip=>$_->{is_vip}}; 46 | } 47 | for(@{$json->{result}{friends}}){ 48 | my $uin = $_->{uin}; 49 | if(exists $state{$_->{uin}}){ 50 | $_->{state} = $state{$uin}{state}; 51 | $_->{client_type} = $state{$uin}{client_type}; 52 | } 53 | else{ 54 | $_->{state} = 'offline'; 55 | $_->{client_type} = 'unknown'; 56 | } 57 | $_->{categorie} = $categories{$_->{categories}}{name}; 58 | $_->{nick} = $info{$uin}{nick}; 59 | $_->{face} = $info{$uin}{face}; 60 | $_->{markname} = $marknames{$uin}{markname}; 61 | $_->{is_vip} = $vipinfo{$uin}{is_vip}; 62 | $_->{vip_level} = $vipinfo{$uin}{vip_level}; 63 | delete $_->{categories}; 64 | } 65 | return $json->{result}{friends}; 66 | } 67 | else{return undef} 68 | } 69 | 1; 70 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_check_verify_code.pm: -------------------------------------------------------------------------------- 1 | use Webqq::Client::Util qw(console); 2 | sub Webqq::Client::_check_verify_code{ 3 | console "检查验证码...\n"; 4 | my $self = shift; 5 | my $ua = $self->{ua}; 6 | my $api_url = 'https://ssl.ptlogin2.qq.com/check'; 7 | my @headers = $self->{type} eq 'webqq'? (Referer=>'https://ui.ptlogin2.qq.com/cgi-bin/login?daid=164&target=self&style=5&mibao_css=m_webqq&appid=1003903&enable_qlogin=0&no_verifyimg=1&s_url=http%3A%2F%2Fweb2.qq.com%2Floginproxy.html&f_url=loginerroralert&strong_login=1&login_state=10&t=20140612002') 8 | : (Referer=>'https://ui.ptlogin2.qq.com/cgi-bin/login?daid=164&target=self&style=16&mibao_css=m_webqq&appid=501004106&enable_qlogin=0&no_verifyimg=1&s_url=http%3A%2F%2Fw.qq.com%2Fproxy.html&f_url=loginerroralert&strong_login=1&login_state=10&t=20131024001') 9 | ; 10 | 11 | my $query_string_ul = $self->{type} eq 'webqq'? 'http%3A%2F%2Fweb2.qq.com%2Floginproxy.html' 12 | : 'http%3A%2F%2Fw.qq.com%2Fproxy.html' 13 | ; 14 | my @query_string = ( 15 | uin => $self->{qq_param}{qq}, 16 | appid => $self->{qq_param}{g_appid}, 17 | js_ver => $self->{qq_param}{g_pt_version}, 18 | js_type => 0, 19 | login_sig => $self->{qq_param}{g_login_sig}, 20 | u1 => $query_string_ul, 21 | r => rand(), 22 | ); 23 | 24 | if($self->{type} eq 'smartqq'){ 25 | unshift @query_string,( 26 | pt_tea => 1, 27 | ); 28 | } 29 | 30 | my @query_string_pairs; 31 | push @query_string_pairs , shift(@query_string) . "=" . shift(@query_string) while(@query_string); 32 | 33 | $ua->cookie_jar()->set_cookie(0,"chkuin",$self->{qq_param}{qq},"/","ptlogin2.qq.com",); 34 | 35 | for(my $i=1;$i<=$self->{ua_retry_times};$i++){ 36 | my $response = $ua->get($api_url.'?'.join("&",@query_string_pairs),@headers); 37 | if($response->is_success){ 38 | my $content = $response->content(); 39 | print $content,"\n" if $self->{debug}; 40 | my %d = (); 41 | @d{qw( retcode cap_cd md5_salt verifysession isRandSalt)} = $content=~/'(.*?)'/g ; 42 | $d{md5_salt} =~ s/\\\\x/\x/g; 43 | #$self->{qq_param}{md5_salt} = eval qq{"$d{md5_salt}"}; 44 | $self->{qq_param}{md5_salt} = $d{md5_salt}; 45 | $self->{qq_param}{cap_cd} = $d{cap_cd}; 46 | $self->{qq_param}{verifysession} = $d{verifysession}; 47 | $self->{qq_param}{isRandSalt} = $d{isRandSalt}; 48 | if($d{retcode} ==0){ 49 | console "检查结果: 很幸运，本次登录不需要验证码\n"; 50 | $self->{qq_param}{verifycode} = $d{cap_cd}; 51 | } 52 | elsif($d{retcode} == 1){ 53 | console "检查结果: 需要输入图片验证码\n"; 54 | $self->{qq_param}{is_need_img_verifycode} = 1 55 | } 56 | 57 | return 1; 58 | } 59 | } 60 | return 0; 61 | } 62 | 1; 63 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Plugin/CpanRecentModule.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Plugin::CpanRecentModule; 2 | use AE; 3 | use Encode; 4 | use XML::Simple; 5 | use POSIX qw(mktime); 6 | use Storable qw(store retrieve); 7 | use Webqq::Client::Util qw(console); 8 | my %data; 9 | sub call{ 10 | my $client = shift; 11 | my $path = shift; 12 | $client->{watchers}{rand()} = AE::timer 600,600,sub{ 13 | print "GET https://metacpan.org/feed/recent?f=n\n" if $client->{debug}; 14 | $client->{asyn_ua}->get('https://metacpan.org/feed/recent?f=n',(),sub{ 15 | my $res = shift; 16 | return unless $res->is_success; 17 | my $xml; 18 | eval{ 19 | $xml = XMLin($res->content,KeepRoot=>1); 20 | }; 21 | if($@){ 22 | console "[Webqq::Client::Plugin::CpanRecentModule]$@\n" if $client->{debug}; 23 | return; 24 | } 25 | unless(%data){ 26 | for my $item (@{ $xml->{'rdf:RDF'}{item} } ){ 27 | $data{$item->{title}} = { 28 | author => $item->{'dc:creator'}, 29 | 'link' => $item->{'link'}, 30 | desc => $item->{'description'}, 31 | date => $item->{'dc:date'}, 32 | }; 33 | } 34 | } 35 | else{ 36 | my @module; 37 | for my $item (@{ $xml->{'rdf:RDF'}{item} } ){ 38 | next if exists $data{$item->{title}}; 39 | my $link = $client->get_dwz($item->{'link'}); 40 | $link = $item->{'link'} unless defined $link; 41 | push @module,{ 42 | author => $item->{'dc:creator'}, 43 | name => $item->{title}, 44 | 'link' => $link, 45 | desc => $item->{description}, 46 | }; 47 | $data{$item->{title}} = { 48 | author => $item->{'dc:creator'}, 49 | 'link' => $item->{'link'}, 50 | desc => $item->{'description'}, 51 | date => $item->{'dc:date'}, 52 | }; 53 | } 54 | 55 | if(@module){ 56 | my @msg; 57 | for(@module){ 58 | push @msg , 59 | "模块：$_->{name}\n" . 60 | "描述：$_->{desc}\n" . 61 | "链接: $_->{link}\n" 62 | ; 63 | } 64 | my $msg = "Hi, CPAN有新模块发布:\n" . join("\n",@msg); 65 | $msg = encode("utf8",$msg); 66 | for my $g (@{ $client->{qq_database}{group} }){ 67 | $client->send_group_message(to_uin=>$g->{ginfo}{gid},content=>$msg); 68 | } 69 | } 70 | } 71 | }); 72 | }; 73 | } 74 | 75 | 1; 76 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_get_discuss_info.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Encode; 3 | use Webqq::Client::Util qw(code2client); 4 | sub Webqq::Client::_get_discuss_info { 5 | my $self = shift; 6 | my $ua = $self->{ua}; 7 | my $did = shift; 8 | return undef if $self->{type} ne 'smartqq'; 9 | my $api_url = 'http://d.web2.qq.com/channel/get_discu_info'; 10 | my @query_string = ( 11 | did => $did, 12 | vfwebqq => $self->{qq_param}{vfwebqq}, 13 | clientid => $self->{qq_param}{clientid}, 14 | psessionid => $self->{qq_param}{psessionid}, 15 | t => time(), 16 | ); 17 | my @headers = ( 18 | Referer => 'http://d.web2.qq.com/proxy.html?v=20130916001&callback=1&id=2', 19 | ); 20 | 21 | my @query_string_pairs; 22 | push @query_string_pairs , shift(@query_string) . "=" . shift(@query_string) while(@query_string); 23 | my $response = $ua->get($api_url.'?'.join("&",@query_string_pairs),@headers); 24 | 25 | if($response->is_success){ 26 | print $response->content,"\n" if $self->{debug}; 27 | my $json; 28 | eval{ 29 | #my $d = $response->content(); 30 | #$d=~s/\\u([a-zA-Z0-9]{4})/encode("utf8",eval qq#"\\x{$1}"#)/eg; 31 | #print $d,"\n" if $self->{debug}; 32 | $json = JSON->new->utf8->decode($response->content()); 33 | }; 34 | print $@ if $@ and $self->{debug}; 35 | $json = {} unless defined $json; 36 | return undef if $json->{retcode}!=0; 37 | return undef unless exists $json->{result}{info}; 38 | 39 | my %mem_list; 40 | my %mem_status; 41 | my %mem_info; 42 | my $minfo = []; 43 | 44 | for(@{ $json->{result}{info}{mem_list} }){ 45 | $mem_list{$_->{mem_uin}}{ruin} = $_->{ruin}; 46 | } 47 | 48 | for(@{ $json->{result}{mem_status} }){ 49 | $mem_status{$_->{uin}}{status} = $_->{status}; 50 | $mem_status{$_->{uin}}{client_type} = $_->{client_type}; 51 | } 52 | 53 | for(@{ $json->{result}{mem_info} }){ 54 | $mem_info{$_->{uin}}{nick} = encode("utf8",$_->{nick}); 55 | } 56 | 57 | for(keys %mem_list){ 58 | my $m = { 59 | uin => $_, 60 | nick => $mem_info{$_}{nick}, 61 | ruin => $mem_list{$_}{ruin}, 62 | }; 63 | if(exists $mem_status{$_}){ 64 | $m->{state} = $mem_status{$_}{status}; 65 | $m->{client_type} = code2client($mem_status{$_}{client_type}); 66 | } 67 | else{ 68 | $m->{state} = 'offline'; 69 | $m->{client_type} = 'unknown'; 70 | } 71 | push @{$minfo},$m; 72 | } 73 | 74 | my $discuss_info = { 75 | dinfo => { 76 | did => $json->{result}{info}{did}, 77 | owner => $json->{result}{info}{discu_owner}, 78 | name => encode("utf8",$json->{result}{info}{discu_name}), 79 | info_seq => $json->{result}{info}{info_seq}, 80 | }, 81 | minfo => (@$minfo>0?$minfo:undef), 82 | } ; 83 | return $discuss_info; 84 | } 85 | else{return undef;} 86 | 87 | } 88 | 1; 89 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Util.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Util; 2 | use Exporter 'import'; 3 | use Encode; 4 | use Encode::Locale; 5 | our @EXPORT_OK = qw(console console_stderr hash truncate code2state code2client) ; 6 | sub console{ 7 | my $bytes = join "",@_; 8 | print encode("locale",decode("utf8",$bytes)); 9 | } 10 | sub console_stderr{ 11 | my $bytes = join "",@_; 12 | print STDERR encode("locale",decode("utf8",$bytes)); 13 | } 14 | 15 | #获取好友列表和群列表的hash函数 16 | sub hash { 17 | my $ptwebqq = shift; 18 | my $uin = shift; 19 | 20 | $uin .= ""; 21 | my @N; 22 | for(my $T =0;$T> 24 & 255 ^ ord(substr($U[0],0,1)); 28 | $V[1] = $uin >> 16 & 255 ^ ord(substr($U[0],1,1)); 29 | $V[2] = $uin >> 8 & 255 ^ ord(substr($U[1],0,1)); 30 | $V[3] = $uin & 255 ^ ord(substr($U[1],1,1)); 31 | @U = (); 32 | for(my $T=0;$T<8;$T++){ 33 | $U[$T] = $T%2==0?$N[$T>>1]:$V[$T>>1]; 34 | } 35 | @N = ("0", "1", "2", "3", "4", "5", "6", "7", "8", "9", "A", "B", "C", "D", "E", "F"); 36 | my $V = ""; 37 | for($T=0;$T<@U;$T++){ 38 | $V .= $N[$U[$T] >> 4 & 15]; 39 | $V .= $N[$U[$T] & 15]; 40 | } 41 | 42 | return $V; 43 | 44 | } 45 | 46 | sub truncate { 47 | my $out_and_err = shift; 48 | my %p = @_; 49 | my $max_bytes = $p{max_bytes} || 200; 50 | my $max_lines = $p{max_lines} || 10; 51 | my $is_truncated = 0; 52 | if(length($out_and_err)>$max_bytes){ 53 | $out_and_err = substr($out_and_err,0,$max_bytes); 54 | $is_truncated = 1; 55 | } 56 | my @l =split /\n/,$out_and_err,$max_lines+1; 57 | if(@l>$max_lines){ 58 | $out_and_err = join "\n",@l[0..$max_lines-1]; 59 | $is_truncated = 1; 60 | } 61 | return $out_and_err. ($is_truncated?"\n(已截断)":""); 62 | } 63 | sub code2state { 64 | my %c = qw( 65 | 10 online 66 | 20 offline 67 | 30 away 68 | 40 hidden 69 | 50 busy 70 | 60 callme 71 | 70 silent 72 | ); 73 | return $c{$_[0]} || "online"; 74 | } 75 | sub code2client { 76 | my %c = qw( 77 | 1 pc 78 | 21 mobile 79 | 24 iphone 80 | 41 web 81 | ); 82 | return $c{$_[0]} || 'unknown'; 83 | } 84 | 85 | 1; 86 | 87 | __END__ 88 | #腾讯获取好友和群列表的hash函数会经常变动，历史版本的hash函数都放在__END__之后 89 | sub hash { 90 | #感谢[PERL学习交流 @小狼]贡献代码 91 | my $ptwebqq = shift; 92 | my $uin = shift; 93 | my $a = $ptwebqq . "password error"; 94 | my $i = ""; 95 | my @E = (); 96 | while(1){ 97 | if(length($i)<= length($a) ){ 98 | $i .= $uin; 99 | last if length($i) == length($a); 100 | } 101 | else{ 102 | $i = substr($i,0,length($a)); 103 | last; 104 | } 105 | } 106 | 107 | for(my $c=0;$c>4 & 15 ]; 114 | $i .= $a[ $E[$c] & 15 ]; 115 | } 116 | return $i; 117 | } 118 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Plugin/LinkInfo.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Plugin::LinkInfo; 2 | use HTML::Parser; 3 | use Webqq::Client::Util qw(console); 4 | use Date::Parse; 5 | use POSIX qw(strftime); 6 | use Encode; 7 | sub call{ 8 | my $client = shift; 9 | my $msg = shift; 10 | if($msg->{content}=~m#(https?://[^/]+[^\s\x80-\xff]+)#s){ 11 | my $url = $1; 12 | print "HEAD $url\n" if $client->{debug}; 13 | $client->{asyn_ua}->head($url,(),sub{ 14 | my $response = shift; 15 | return if !$response->is_success; 16 | if($response->header("content-type") !~ /text\/html/){ 17 | print "$url [not-text/html]\n"; 18 | return; 19 | } 20 | print "GET $url\n" if $client->{debug}; 21 | $client->{asyn_ua}->get($url,(),sub{ 22 | my $response = shift; 23 | return if !$response->is_success; 24 | return if $response->header("content-type") !~ /text\/html/; 25 | my $charset ; 26 | if($response->header("content-type")=~/charset\s*=\s*(utf\-?8|gb2312|gbk|gb18030)/i){ 27 | $charset = $1; 28 | } 29 | elsif($response->content()=~/{debug}; 38 | my $p=HTML::Parser->new; 39 | $p->ignore_elements(qw(script style a img)); 40 | #$p->report_tags(qw(div p)); 41 | $p->utf8_mode(0); 42 | 43 | my $is_title = 0; 44 | my $title; 45 | my $content; 46 | my $expires = $response->header("last-modified"); 47 | if(defined $expires){ 48 | $expires = strftime('%c',localtime(str2time($expires))); 49 | $expires =~s/ \d+时\d+分\d+秒$//; 50 | } 51 | 52 | $p->handler(start=>sub{ 53 | my $tagname = shift; 54 | $is_title=($tagname eq 'title'?1:0); 55 | $p->handler(text=>sub{my $text = shift;$is_title?($title .=$text):($content .= $text);},"text"); 56 | },"tagname"); 57 | 58 | my $html; 59 | if($charset=~/^gb/i){ 60 | $html = decode("gb2312",$response->content); 61 | } 62 | elsif($charset=~/^utf/i){ 63 | $html = decode("utf8",$response->content); 64 | } 65 | $p->parse($html); 66 | $p->eof; 67 | $title=~s/\s+|&[^&;]+;/ /g; 68 | $content=~s/\s+|&[^&;]+;/ /g; 69 | 70 | return unless $title; 71 | return unless $content; 72 | 73 | $title = substr($title,0,100) . (length($title)>100?"...":""); 74 | $content = substr($content,0,100) . "..."; 75 | 76 | $url = substr($url,0,50) . (length($url)>50?"...":""); 77 | 78 | $title = "【网页标题】" . encode("utf8",$title); 79 | $expires = "【更新时间】" . $expires . "\n" if defined $expires; 80 | $content = "【网页正文】" . encode("utf8",$content); 81 | 82 | $client->reply_message($msg,"$title\n${expires}$content\n$url"); 83 | }); 84 | }); 85 | } 86 | } 87 | 1; 88 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_get_group_info.pm: -------------------------------------------------------------------------------- 1 | use JSON; 2 | use Webqq::Client::Util qw(console code2state code2client); 3 | sub Webqq::Client::_get_group_info { 4 | my $self = shift; 5 | my $gcode = shift; 6 | my $ua = $self->{ua}; 7 | my $api_url = 'http://s.web2.qq.com/api/get_group_info_ext2'; 8 | my @query_string = ( 9 | gcode => $gcode, 10 | vfwebqq => $self->{qq_param}{vfwebqq}, 11 | t => time(), 12 | ); 13 | 14 | if($self->{type} eq 'webqq'){ 15 | splice @query_string,2,0,(cb => "undefined"); 16 | } 17 | 18 | my @query_string_pairs; 19 | push @query_string_pairs , shift(@query_string) . "=" . shift(@query_string) while(@query_string); 20 | my @headers = $self->{type} eq 'webqq'? (Referer => 'http://s.web2.qq.com/proxy.html?v=20110412001&callback=1&id=3') 21 | : (Referer => 'http://s.web2.qq.com/proxy.html?v=20130916001&callback=1&id=1') 22 | ; 23 | my $response = $ua->get($api_url.'?'.join("&",@query_string_pairs),@headers); 24 | if($response->is_success){ 25 | my $json; 26 | eval{ 27 | $json = JSON->new->utf8->decode($response->content()) ; 28 | }; 29 | $json = {} unless defined $json; 30 | my $ginfo_status = exists $json->{result}{ginfo}?"[ginfo-ok]":"[ginfo-not-ok]"; 31 | my $minfo_status = exists $json->{result}{minfo}?"[minfo-ok]":"[minfo-not-ok]"; 32 | 33 | if($self->{debug}){ 34 | print substr($response->content(),0,80),"${ginfo_status}${minfo_status}...\n"; 35 | console $@."\n" if $@; 36 | } 37 | 38 | return undef unless exists $json->{result}{ginfo}; 39 | #return undef unless exists $json->{result}{minfo}; 40 | delete $json->{result}{ginfo}{members}; 41 | for(keys %{$json->{result}{ginfo}}){ 42 | $json->{result}{ginfo}{$_} = encode("utf8",$json->{result}{ginfo}{$_}); 43 | } 44 | #retcode等于0说明包含完整的ginfo和minfo 45 | if($json->{retcode}==0){ 46 | return undef unless exists $json->{result}{minfo}; 47 | my %cards; 48 | for (@{ $json->{result}{cards} }){ 49 | $cards{$_->{muin}} = $_->{card}; 50 | } 51 | my %state; 52 | for(@{ $json->{result}{stats} }){ 53 | $state{$_->{uin}}{client_type} = $_->{client_type}; 54 | $state{$_->{uin}}{state} = code2state($_->{'stat'}); 55 | } 56 | for my $m(@{ $json->{result}{minfo} }){ 57 | $m->{card} = $cards{$m->{uin}} if exists $cards{$m->{uin}} ; 58 | if(exists $state{$m->{uin}}){ 59 | $m->{state} = $state{$m->{uin}}{state}; 60 | $m->{client_type} = code2client($state{$m->{uin}}{client_type}); 61 | } 62 | else{ 63 | $m->{state} = 'offline'; 64 | $m->{client_type} = 'unknown'; 65 | } 66 | for(keys %$m){ 67 | $m->{$_} = encode("utf8",$m->{$_}); 68 | } 69 | } 70 | my $group_info = { 71 | ginfo => $json->{result}{ginfo}, 72 | minfo => $json->{result}{minfo}, 73 | }; 74 | #查询结果同时进行缓存，以优化查询速度 75 | #$self->{cache_for_group}->store($gcode,$group_info); 76 | return $group_info; 77 | } 78 | #只存在ginfo 79 | else{ 80 | my $group_info = { 81 | ginfo => $json->{result}{ginfo}, 82 | }; 83 | return $group_info; 84 | } 85 | } 86 | else{return undef;} 87 | } 88 | 1; 89 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Plugin/PostImgVerifycode.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Plugin::PostImgVerifycode; 2 | use IO::Socket::INET; 3 | use Webqq::Client::Util qw(console); 4 | use HTTP::Date; 5 | use IO::Handle; 6 | use Sys::HostIP qw(ips); 7 | use Mail::SendEasy; 8 | use File::Basename; 9 | sub call{ 10 | my $client = shift; 11 | my($img_verifycode_file,$smtp) =@_; 12 | unless(ref $smtp eq 'HASH'){ 13 | console "PostImgVerifycode需要正确的smtp信息\n"; 14 | exit; 15 | } 16 | my $img_path = basename($img_verifycode_file); 17 | my ($internet_host) = grep { 18 | $_ ne '127.0.0.1' 19 | and $_ ne '::1' 20 | and $_ !~/^(10\.|172\.16\.|192\.168\.)/ 21 | } @{ ips() }; 22 | my $status = Mail::SendEasy::send( 23 | smtp =>$smtp->{smtp}, 24 | user =>$smtp->{user}, 25 | pass =>$smtp->{pass}, 26 | from =>$smtp->{from}, 27 | from_title => $smtp->{from_title}, 28 | subject =>$smtp->{subject}, 29 | to =>$smtp->{to}, 30 | anex => $img_verifycode_file, 31 | msg =>"主人，登录需要验证码，请点击以下链接输入验证码: http://$internet_host:1987/post_img_code", 32 | ); 33 | my $s = IO::Socket::INET->new( 34 | LocalPort => 1987, 35 | Proto => 'tcp' , 36 | Reuse => 1, 37 | Blocking => 1, 38 | Listen => SOMAXCONN, 39 | ) or die $!; 40 | my $html= <<"HTML"; 41 | 42 | 43 | 44 | 45 | 46 |
47 |
48 | 验证码： 49 | 50 | 51 |
52 | 53 | 54 | HTML 55 | 56 | while(my $c = $s->accept()){ 57 | my $uri; 58 | $c->autoflush(1); 59 | while(<$c>){ 60 | last if /^\s+$/; 61 | (undef,$uri,undef)= split /\s+/,$_ if $_ =~/^GET/; 62 | } 63 | if($uri eq "/$img_path"){ 64 | my $data; 65 | open my $img,$img_verifycode_file or die $!; 66 | while((read $img,my $buf,4096)!=0){ 67 | $data .= $buf; 68 | } 69 | close $img; 70 | my $len = length($data); 71 | print $c 72 | "HTTP/1.1 200 OK\r\n" . 73 | "Date: " . time2str() . "\r\n" . 74 | "Content-Type: image/jpeg\r\n" . 75 | "Content-Length: $len\r\n" . 76 | "\r\n" . 77 | $data; 78 | } 79 | elsif($uri eq '/post_img_code'){ 80 | my $len = length($html); 81 | print $c 82 | "HTTP/1.1 200 OK\r\n" . 83 | "Date: " . time2str() . "\r\n" . 84 | "Content-Type: text/html;charset=utf-8\r\n" . 85 | "Content-Length: $len\r\n" ; 86 | print $c "\r\n"; 87 | print $c $html; 88 | } 89 | elsif($uri =~ /\/img_code\?code=(.{4})/){ 90 | my $code = $1; 91 | my $data = "验证码已提交" ; 92 | my $len = length($data); 93 | print $c 94 | "HTTP/1.1 200 OK\r\n" . 95 | "Date: " . time2str() . "\r\n" . 96 | "Content-Type: text/html;charset=utf-8\r\n" . 97 | "Content-Length: $len\r\n" . 98 | "\r\n" . 99 | $data; 100 | return $code if defined $code and length($code)==4; 101 | } 102 | else{ 103 | print $c 104 | "HTTP/1.1 404 Not Found\r\n" . 105 | "Date: " . time2str() . "\r\n" . 106 | "Content-Length: 0\r\n"; 107 | } 108 | } 109 | } 110 | 111 | 1; 112 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Plugin/Msgstat.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Plugin::Msgstat; 2 | use Storable qw(retrieve store); 3 | use File::Path qw/mkpath/; 4 | use Webqq::Client::Util qw(console console_stderr); 5 | 6 | if($^O !~ /linux/){ 7 | console_stderr "Webqq::Client::App::Msgstat只能运行在linux系统上\n"; 8 | exit; 9 | } 10 | mkpath "/tmp/webqq/data",{mode=>0711}; 11 | 12 | my $msgstat; 13 | my $once = 1; 14 | $msgstat=(-e "/tmp/webqq/data/msgstat")?retrieve("/tmp/webqq/data/msgstat"):{}; 15 | sub call{ 16 | my ($client,$msg,$time,$group_filter) = @_; 17 | $time = "17:30" unless defined $time; 18 | return 1 if $msg->{type} ne 'group_message'; 19 | my $group_code = $msg->group_code; 20 | my $group_name = $msg->group_name; 21 | my $from_nick = $msg->from_nick; 22 | my $from_card = $msg->from_card; 23 | my $from_qq = $msg->from_qq; 24 | 25 | return 1 unless $group_name; 26 | return 1 unless $from_qq; 27 | 28 | $msgstat->{$group_name}{$from_qq}{nick}=$from_nick; 29 | $msgstat->{$group_name}{$from_qq}{card}=$from_card; 30 | $msgstat->{$group_name}{$from_qq}{msg}++; 31 | $msgstat->{$group_name}{$from_qq}{sys_img}++ if $msg->{content} =~/\[系统表情\]/; 32 | $msgstat->{$group_name}{$from_qq}{other_img}++ if $msg->{content} =~/\[图片\]/; 33 | 34 | if($msg->{content} =~ /^-msgstat$/ and $from_qq == 308165330){ 35 | my $content = Report($msgstat,$group_name); 36 | $client->reply_message($msg,$content) if $content; 37 | } 38 | 39 | if($once){ 40 | $client->{watchers}{rand()} = AE::timer 60,300,sub{ 41 | console "消息统计数据存盘\n" if $client->{debug}; 42 | store($msgstat,"/tmp/webqq/data/msgstat"); 43 | }; 44 | #my $group_name = "PERL学习交流"; 45 | $client->add_job("群发言排行榜",$time,sub{ 46 | for(@{$client->{qq_database}{group_list}}){ 47 | if(defined $group_filter){ 48 | next if $_->{name} ne $group_filter; 49 | } 50 | my $gid = $_->{gid} ; 51 | my $content = Report($msgstat,$_->{name}); 52 | $content = "群发言排行榜:\n" . $content if $content; 53 | if($gid and $content){ 54 | $client->send_group_message( 55 | $client->create_group_msg( 56 | to_uin=>$gid, 57 | content=>$content, 58 | group_code=>$_->{code} 59 | ) 60 | ); 61 | } 62 | } 63 | }); 64 | 65 | $client->add_job("消息统计数据清空","23:59",sub{ 66 | $msgstat = {}; 67 | }); 68 | $once=0; 69 | } 70 | return 1; 71 | } 72 | 73 | sub Report{ 74 | my $msgstat = shift; 75 | my $group_name = shift; 76 | my $top = shift; 77 | $top>0?($top--):($top=10); 78 | my $content = ""; 79 | my @sort_qq = 80 | sort {$msgstat->{$group_name}{$b}{other_img}<=>$msgstat->{$group_name}{$a}{other_img} or $msgstat->{$group_name}{$b}{other_img}/$msgstat->{$group_name}{$b}{msg} <=> $msgstat->{$group_name}{$a}{other_img}/$msgstat->{$group_name}{$a}{msg}} 81 | grep {$msgstat->{$group_name}{$_}{msg}!=0} 82 | keys %{$msgstat->{$group_name}}; 83 | 84 | my @top_qq = @sort_qq[0..$top]; 85 | for(@top_qq){ 86 | #next if $msgstat->{$group_name}{$_}{other_img} ==0; 87 | next if $msgstat->{$group_name}{$_}{msg} ==0; 88 | my $nick = $msgstat->{$group_name}{$_}{card}||$msgstat->{$group_name}{$_}{nick}; 89 | $content .= sprintf("%4s %4s %4s %s\n", 90 | $msgstat->{$group_name}{$_}{msg}+0, 91 | $msgstat->{$group_name}{$_}{other_img}+0, 92 | sprintf("%.1f",($msgstat->{$group_name}{$_}{other_img})*100/$msgstat->{$group_name}{$_}{msg}), 93 | $nick, 94 | ); 95 | } 96 | $content = sprintf("%4s %4s %4s %s\n","消息","图片","水度","昵称") . $content if $content; 97 | return $content; 98 | } 99 | 100 | 1; 101 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Plugin/SmartReply.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Plugin::SmartReply; 2 | use JSON; 3 | use AE; 4 | use Encode; 5 | use POSIX qw(strftime); 6 | use Webqq::Client::Util qw(truncate console); 7 | my $API = 'http://www.tuling123.com/openapi/api'; 8 | my %limit; 9 | my %ban; 10 | my @limit_reply = ( 11 | "对不起，请不要这么频繁的艾特我", 12 | "对不起，您的艾特次数太多", 13 | "说这么多话不累么，请休息几分钟", 14 | "能不能小窗我啊，别吵着大家", 15 | ); 16 | #my $API = 'http://www.xiaodoubi.com/bot/api.php?chat='; 17 | my $once = 1; 18 | sub call{ 19 | my $client = shift; 20 | my $msg = shift; 21 | return if $msg->{type} !~ /^message|group_message|sess_message$/; 22 | my $self_nick = $client->{qq_database}{user}{nick}; 23 | return if $msg->{allow_plugin} == 0; 24 | my $msg_type = $msg->{type}; 25 | if($msg_type eq 'group_message'){ 26 | return 1 if $msg->{content} !~/\@\Q$self_nick \E/; 27 | } 28 | my $userid = $msg->from_qq; 29 | return 1 if exists $ban{$userid}; 30 | 31 | my $from_nick; 32 | my $from_city = $msg->from_city if ($msg->{type} eq 'group_message' or $msg->{type} eq 'message'); 33 | if($msg->{type} eq 'group_message'){ 34 | $from_nick = $msg->from_card || $msg->from_nick; 35 | } 36 | else{ 37 | $from_nick = $msg->from_nick; 38 | } 39 | 40 | if($msg->{type} eq 'group_message'){ 41 | my $key = strftime("%H",localtime(time)); 42 | $limit{$key}{$msg->{from_uin}}{$userid}++; 43 | 44 | my $limit = $limit{$key}{$msg->{from_uin}}{$userid}; 45 | if($limit>=3 and $limit<=4){ 46 | $client->reply_message($msg,"\@$from_nick " . $limit_reply[int rand($#limit_reply+1)]); 47 | return 1; 48 | } 49 | 50 | if($limit >=5 and $limit <=6){ 51 | $client->reply_message($msg,"\@$from_nick " . "警告，您艾特过于频繁，即将被列入黑名单，请克制\n"); 52 | return 1; 53 | } 54 | 55 | if($limit > 6){ 56 | $ban{$userid} = 1; 57 | $client->reply_message($msg,"\@$from_nick " . "您已被列入黑名单，1小时内提问无视\n"); 58 | my $watcher = rand(); 59 | $client->{watchers}{$watcher} = AE::timer 3600,0,sub{ 60 | delete $client->{watchers}{$watcher}; 61 | delete $ban{$userid}; 62 | }; 63 | return 1; 64 | } 65 | } 66 | 67 | my $input = $msg->{content}; 68 | $input=~s/\@\Q$self_nick\E ?|\[[^\[\]]+\]\x01|\[[^\[\]]+\]//g; 69 | return unless $input; 70 | my @query_string = ( 71 | "key" => "4c53b48522ac4efdfe5dfb4f6149ae51", 72 | "userid" => $userid, 73 | "info" => $input, 74 | ); 75 | push @query_string,(loc=>$from_city."市") if $from_city; 76 | my @query_string_pairs; 77 | push @query_string_pairs , shift(@query_string) . "=" . shift(@query_string) while(@query_string); 78 | $client->{asyn_ua}->get($API . "?" . join("&",@query_string_pairs),(),sub{ 79 | my $res =shift; 80 | if($client->{debug}){ 81 | print "GET " . $API . "?" . join("&",@query_string_pairs),"\n"; 82 | print $res->as_string,"\n"; 83 | } 84 | my $reply; 85 | my $data = {}; 86 | eval{ 87 | $data = JSON->new->utf8->decode($res->content); 88 | }; 89 | if($@){ 90 | print $@,"\n" if $client->{debug}; 91 | return 1; 92 | } 93 | return 1 if $data->{code}=~/^4000[1-7]$/; 94 | if($data->{code} == 100000){ 95 | $reply = encode("utf8",$data->{text}); 96 | } 97 | elsif($data->{code}== 200000){ 98 | $reply = encode("utf8","$data->{text}\n$data->{url}"); 99 | } 100 | else{ 101 | return 1; 102 | } 103 | $reply = "\@$from_nick " . $reply if $msg_type eq 'group_message' and rand(100)>20; 104 | $reply = truncate($reply,max_bytes=>300,max_lines=>5) if $msg_type eq 'group_message'; 105 | $client->reply_message($msg,$reply) if $reply; 106 | }); 107 | 108 | if($once){ 109 | $client->{watchers}{rand()} = AE::timer 3600,3600,sub{ 110 | my $key = strftime("%H",localtime(time-3600)); 111 | delete $limit{$key}; 112 | }; 113 | $once = 0; 114 | } 115 | 116 | return 1; 117 | } 118 | 1; 119 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Plugin/Perlcode.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Plugin::Perlcode; 2 | use File::Temp qw/tempfile/; 3 | use Webqq::Client::Util qw(console_stderr); 4 | use File::Path qw/mkpath rmtree/; 5 | use IPC::Run qw(run timeout start pump finish harness); 6 | use POSIX qw(strftime); 7 | 8 | if($^O !~ /linux/){ 9 | console_stderr "Webqq::Client::App::Perlcode只能运行在linux系统上\n"; 10 | exit; 11 | } 12 | chomp(my $PERL_COMMAND = `/bin/env which perl`); 13 | mkpath "/tmp/webqq/log/",{owner=>"nobody",group=>"nobody",mode=>0555}; 14 | mkpath "/tmp/webqq/bin/",{owner=>"nobody",group=>"nobody",mode=>0555}; 15 | mkpath "/tmp/webqq/src/",{owner=>"nobody",group=>"nobody",mode=>0555}; 16 | chown +(getpwnam("nobody"))[2,3],"/tmp/webqq/"; 17 | chown +(getpwnam("nobody"))[2,3],"/tmp/webqq/log"; 18 | chown +(getpwnam("nobody"))[2,3],"/tmp/webqq/bin"; 19 | chown +(getpwnam("nobody"))[2,3],"/tmp/webqq/src"; 20 | 21 | open LOG,">>/tmp/webqq/log/exec.log" or die $!; 22 | sub call{ 23 | my ($client,$msg,$perl_path) = @_; 24 | return 1 if time - $msg->{msg_time} > 10; 25 | $PERL_COMMAND = $perl_path if defined $perl_path; 26 | if($msg->{content} =~/(?:>>>)(.*?)(?:__END__|$)/s or $msg->{content} =~/perl\s+-e\s+'([^']+)'/s){ 27 | $msg->{allow_plugin} = 0; 28 | my $doc = ''; 29 | my $code = $1; 30 | $code=~s/^\s+|\s+$//g; 31 | $code=~s/CORE:://g; 32 | $code=~s/CORE::GLOBAL:://g; 33 | if($code){ 34 | $code = q#use feature qw(say);BEGIN{use File::Path;use BSD::Resource;setrlimit(RLIMIT_NOFILE,10,10);setrlimit(RLIMIT_CPU,8,8);setrlimit(RLIMIT_FSIZE,1024,1024);setrlimit(RLIMIT_NPROC,5,5);setrlimit(RLIMIT_STACK,1024*1024*10,1024*1024*10);setrlimit(RLIMIT_DATA,1024*1024*10,1024*1024*10);*CORE::GLOBAL::fork=sub{};}$|=1;use POSIX qw(setuid setgid);{my($u,$g)= (getpwnam("nobody"))[2,3];mkpath('/tmp/webqq/bin/',{owner=>$u,group=>$g,mode=>0555}) unless -e '/tmp/webqq/bin';chdir '/tmp/webqq/bin';chroot '/tmp/webqq/bin' or die "chroot fail: $!";chdir "/";setuid($u);setgid($g);%ENV=();}# . $code; 35 | my ($fh, $filename) = tempfile("webqq_perlcode_XXXXXXXX",SUFFIX =>".pl",DIR => "/tmp/webqq/src"); 36 | print $code,"\n",$filename,"\n" if $client->{debug}; 37 | print $fh $code; 38 | close $fh; 39 | chomp(my $syntax_check = `$PERL_COMMAND -Ttc '$filename' 2>&1`); 40 | if($syntax_check =~/syntax OK/){ 41 | my $out_and_err = ''; 42 | my $h; 43 | eval{ 44 | my ($line,$len) = (0,0); 45 | my @cmd = ($PERL_COMMAND,"-Tt",$filename); 46 | $h= harness 47 | \@cmd,'>&',\$out_and_err,timeout(5) or $doc="@灰灰 run perlcode fail"; 48 | while($len<=200 and $line <=10){ 49 | $h->pump; 50 | $out_and_err=~s/\Q$filename\E/CODE/g; 51 | $len = length($out_and_err); 52 | $line = ()=$out_and_err=~m/\n/g; 53 | select undef,undef,undef,0.01; 54 | } 55 | $h->kill_kill; 56 | }; 57 | 58 | if($@=~/^IPC::Run: timeout on timer/){ 59 | $doc .= "代码执行结果:\n". &truncate($out_and_err) . "\n(代码执行超时)" ; 60 | $h->kill_kill; 61 | } 62 | elsif($@=~/^process ended prematurely/){ 63 | $doc = "代码执行结果:\n". &truncate($out_and_err); 64 | } 65 | else{ $doc = "代码执行结果:\n". &truncate($out_and_err);} 66 | } 67 | 68 | else{$doc = "代码语法检查错误:\n" . $syntax_check;} 69 | $doc=~s/\Q$filename\E/CODE/g; 70 | unlink $filename; 71 | print LOG strftime("%Y-%m-%d %H:%M:%S",localtime()),"\n",$code,"\n",$doc,"\n"; 72 | 73 | $client->reply_message($msg,$doc) if $doc; 74 | } 75 | return 0; 76 | } 77 | 78 | return 1; 79 | } 80 | sub truncate { 81 | my $out_and_err = shift; 82 | my $is_truncated = 0; 83 | if(length($out_and_err)>200){ 84 | $out_and_err = substr($out_and_err,0,200); 85 | $is_truncated = 1; 86 | } 87 | my @l =split /\n/,$out_and_err,11; 88 | if(@l>10){ 89 | $out_and_err = join "\n",@l[0..9]; 90 | $is_truncated = 1; 91 | } 92 | return $out_and_err. ($is_truncated?"\n(已截断)":""); 93 | } 94 | 1; 95 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Plugin/ShowMsg.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Plugin::ShowMsg; 2 | use Webqq::Client::Util qw(console); 3 | use POSIX qw(strftime); 4 | use Encode; 5 | 6 | sub call{ 7 | my $client = shift; 8 | my $msg = shift; 9 | my $attach = shift; 10 | if($msg->{type} eq 'group_message'){ 11 | #$msg是一个群消息的hash引用，包含如下key 12 | 13 | # type #消息类型 14 | # msg_id #系统生成的消息id 15 | # from_uin #消息来源uin，可以通过这个uin进行消息回复 16 | # to_uin #接受者uin，通常就是自己的qq号 17 | # msg_time #消息发送时间 18 | # content #消息内容 19 | # send_uin #发送者uin 20 | # group_code #群的标识 21 | 22 | # 你可以使用use Data::Dumper;print Dumper $msg来查看$msg的结构 23 | 24 | # $msg使用了Automated accessor generation技术，每个hash的key都同时对应一个get方法 25 | # 即，你可以使用$msg->{key}或者$msg->key任意一种方式获取你想要的数据 26 | # 此外，使用$msg->method()的方式，你还会增加几个$msg->{key}没有的数据项 27 | # $msg->from_qq 28 | # $msg->from_nick 29 | # $msg->group_name 30 | 31 | my $group_name = $msg->group_name; 32 | my $msg_sender_nick = $msg->from_nick; 33 | my $msg_sender_card = $msg->from_card if $msg->{msg_class} eq 'recv'; 34 | my $msg_sender = $msg_sender_card || $msg_sender_nick; 35 | $msg_sender = "昵称未知" unless defined $msg_sender; 36 | #my $msg_sender_qq = $msg->from_qq; 37 | format_msg( 38 | strftime("[%y/%m/%d %H:%M:%S]",localtime($msg->{msg_time})) 39 | . "\@$msg_sender(在群:$group_name) 说: ", 40 | $msg->{content} . $attach 41 | ); 42 | } 43 | #我们多了如下的get数据项 44 | # $msg->from_nick 45 | # $msg->from_qq 46 | # $msg->from_markname 47 | # $msg->from_categories 48 | elsif($msg->{type} eq 'message'){ 49 | my $msg_sender_nick = $msg->from_nick; 50 | my $msg_sender_markname = $msg->from_markname if $msg->{msg_class} eq 'recv'; 51 | my $msg_sender = $msg_sender_markname || $msg_sender_nick; 52 | my $msg_receiever_nick = $msg->to_nick; 53 | my $msg_receiever_markname = $msg->to_markname if $msg->{msg_class} eq 'send'; 54 | my $msg_receiever = $msg_receiever_markname || $msg_receiever_nick; 55 | $msg_receiever = "昵称未知" unless defined $msg_receiever; 56 | $msg_sender = "昵称未知" unless defined $msg_sender; 57 | 58 | format_msg( 59 | strftime("[%y/%m/%d %H:%M:%S]",localtime($msg->{msg_time})) 60 | . "\@$msg_sender(对好友:\@$msg_receiever) 说: ", 61 | $msg->{content} . $attach 62 | ); 63 | } 64 | 65 | #消息是临时消息 66 | # $msg->from_qq 67 | # $msg->from_nick 68 | elsif($msg->{type} eq 'sess_message'){ 69 | my $msg_sender_nick = $msg->from_nick; 70 | my $msg_receiever_nick = $msg->to_nick; 71 | my $via_name = $msg->via_name; 72 | my $via_type = $msg->via_type; 73 | $msg_sender_nick = "昵称未知" unless defined $msg_sender_nick; 74 | $msg_receiever_nick= "昵称未知" unless defined $msg_receiever_nick; 75 | if($msg->{msg_class} eq 'recv'){ 76 | format_msg( 77 | strftime("[%y/%m/%d %H:%M:%S]",localtime($msg->{msg_time})) 78 | . "\@$msg_sender_nick(来自$via_type:$via_name 对:\@$msg_receiever_nick) 说: ", 79 | $msg->{content} . $attach 80 | ); 81 | } 82 | elsif($msg->{msg_class} eq 'send'){ 83 | format_msg( 84 | strftime("[%y/%m/%d %H:%M:%S]",localtime($msg->{msg_time})) 85 | . "\@$msg_sender_nick(对:\@$msg_receiever_nick 来自$via_type:$via_name) 说: ", 86 | $msg->{content} . $attach 87 | ); 88 | } 89 | } 90 | 91 | elsif($msg->{type} eq 'discuss_message'){ 92 | my $discuss_name = $msg->discuss_name; 93 | my $msg_sender = $msg->from_nick; 94 | $msg_sender = "昵称未知" unless defined $msg_sender; 95 | #my $msg_sender_qq = $msg->from_qq; 96 | format_msg( 97 | strftime("[%y/%m/%d %H:%M:%S]",localtime($msg->{msg_time})) 98 | . "\@$msg_sender(在讨论组:$discuss_name) 说: ", 99 | $msg->{content} . $attach 100 | ); 101 | 102 | } 103 | 104 | return 1; 105 | } 106 | 107 | sub format_msg{ 108 | my $msg_header = shift; 109 | my $msg_content = shift; 110 | my @msg_content = split /\n/,$msg_content; 111 | $msg_header = decode("utf8",$msg_header); 112 | my $chinese_count=()=$msg_header=~/\p{Han}/g ; 113 | my $total_count = length($msg_header); 114 | $msg_header=encode("utf8",$msg_header); 115 | 116 | my @msg_header = ($msg_header,(' ' x ($total_count-$chinese_count+$chinese_count*2)) x $#msg_content ); 117 | while(@msg_content){ 118 | my $lh = shift @msg_header; 119 | my $lc = shift @msg_content; 120 | #你的终端可能不是UTF8编码，为了防止乱码，做下编码自适应转换 121 | console $lh, $lc,"\n"; 122 | } 123 | } 124 | 125 | 1; 126 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Plugin/MsgSync.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Plugin::MsgSync; 2 | use strict; 3 | use AnyEvent::IRC::Client; 4 | use AnyEvent::IRC::Util qw(prefix_nick); 5 | use List::Util qw(first); 6 | use Webqq::Client::Util qw(truncate); 7 | my $irc_client = new AnyEvent::IRC::Client; 8 | my $once = 1; 9 | my $is_irc_join = 0; 10 | my $debug = 0; 11 | 12 | my $irc = {}; 13 | my $group_name = []; 14 | 15 | my @group_list ; 16 | sub call { 17 | my $client = shift; 18 | my $msg = shift; 19 | $debug = $client->{debug}; 20 | my %p = @_; 21 | $group_name = $p{group}; 22 | if($group_name eq "all"){ 23 | @group_list = @{$client->{qq_database}{group_list}}; 24 | } 25 | elsif(ref $group_name eq "ARRAY"){ 26 | @group_list = (); 27 | for my $g (@{$client->{qq_database}{group_list}}){ 28 | push @group_list,$g if first {$g->{name} eq $_} @$group_name; 29 | } 30 | } 31 | 32 | if ($once) { 33 | $irc = $p{irc}; 34 | if(defined $irc){ 35 | $irc->{server} = "irc.freenode.net" unless defined $irc->{server}; 36 | $irc->{port} = 6667 unless defined $irc->{port}; 37 | $irc->{channel} = "#ChinaPerl" unless defined $irc->{channel}; 38 | die "[".__PACKAGE__."] irc nick must be set\n" unless defined $irc->{nick}; 39 | $irc_client->reg_cb( 40 | registered => sub { 41 | print "[".__PACKAGE__."] $irc->{nick} has registered $irc->{server}:$irc->{port}\n" if $debug; 42 | $irc_client->send_msg(JOIN=>$irc->{channel}); 43 | }, 44 | join => sub { 45 | print "[".__PACKAGE__."] $irc->{nick} has joined $irc->{channel}\n" if $debug; 46 | $is_irc_join = 1; 47 | }, 48 | publicmsg => sub { 49 | my($self,$channel, $ircmsg) = @_; 50 | my $sender_nick = prefix_nick($ircmsg) || "UnknownNick"; 51 | my $msg_content = $ircmsg->{params}[1]; 52 | return if $ircmsg->{command} ne "PRIVMSG"; 53 | return if $msg_content =~/^[~ ]/; 54 | #if($debug){ 55 | # print "[".__PACKAGE__."] \@$sender_nick (in $channel) say: $msg_content\n"; 56 | #} 57 | for(@group_list){ 58 | $client->send_group_message( 59 | to_uin => $_->{gid}, 60 | content => "[${sender_nick}#irc] " . $msg_content 61 | ); 62 | } 63 | }, 64 | disconnect => sub { 65 | print "[".__PACKAGE__."] $irc->{nick} has quit $irc->{server}:$irc->{port}\n" if $debug; 66 | $irc_client->connect( 67 | $irc->{server}, 68 | $irc->{port}, 69 | {nick=>$irc->{nick},user=>$irc->{user},real=>$irc->{real},password=>$irc->{password}}, 70 | ); 71 | }, 72 | ); 73 | $irc_client->connect( 74 | $irc->{server}, 75 | $irc->{port}, 76 | {nick=>$irc->{nick},user=>$irc->{user},real=>$irc->{real},password=>$irc->{password}}, 77 | ); 78 | } 79 | $client->{watchers}{rand()} = AE::timer 600,60,sub { 80 | if($irc_client->registered()){ 81 | unless(defined $irc_client->channel_list($irc->{channel})){ 82 | $is_irc_join = 0; 83 | $irc_client->send_msg(JOIN=>$irc->{channel}) ; 84 | } 85 | } 86 | else{ 87 | $is_irc_join = 0; 88 | $irc_client->connect( 89 | $irc->{server}, 90 | $irc->{port}, 91 | {nick=>$irc->{nick},user=>$irc->{user},real=>$irc->{real},password=>$irc->{password}}, 92 | ) 93 | } 94 | }; 95 | $once = 0; 96 | } 97 | return 1 if ($msg->{msg_class} eq "send" and $msg->{content}=~/^\[.*?#.+?\]/); 98 | return 1 if $msg->{type} ne 'group_message'; 99 | my $gn = $msg->group_name; 100 | return 1 unless first {$gn eq $_} @$group_name; 101 | my $msg_sender_nick = $msg->from_nick; 102 | my $msg_sender_card = $msg->from_card if $msg->{msg_class} eq 'recv'; 103 | my $msg_sender = $msg_sender_card || $msg_sender_nick; 104 | $msg_sender = "昵称未知" unless defined $msg_sender; 105 | $msg_sender = $client->{qq_database}{user}{nick} if $msg_sender eq "我" and $msg->{msg_class} eq 'send'; 106 | 107 | 108 | for(grep {$gn ne $_->{name}} @group_list){ 109 | $client->send_group_message( 110 | to_uin => $_->{gid}, 111 | content => "[${msg_sender}#$gn] " . $msg->{content} 112 | ); 113 | } 114 | 115 | if($is_irc_join){ 116 | for(split /\n/,truncate($msg->{content},max_bytes=>2000,max_lines=>10) ){ 117 | $irc_client->send_msg(PRIVMSG => $irc->{channel}, "[$msg_sender] ". $_); 118 | } 119 | } 120 | } 121 | 1; 122 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Plugin/Perldoc.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Client::Plugin::Perldoc; 2 | use JSON; 3 | use Webqq::Client::Util qw(console_stderr truncate); 4 | if($^O !~ /linux/){ 5 | console_stderr "Webqq::Client::App::Perldoc只能运行在linux系统上\n"; 6 | exit; 7 | } 8 | chomp(my $PERLDOC_COMMAND = `/bin/env which perldoc`); 9 | 10 | my %last_module_time ; 11 | 12 | sub call{ 13 | my $client = shift; 14 | my $msg = shift; 15 | return 1 if time - $msg->{msg_time} > 10; 16 | my $perldoc_path = shift; 17 | $PERLDOC_COMMAND = $perldoc_path if defined $perldoc_path; 18 | if($msg->{content} =~/perldoc\s+-(v|f)\s+([^ ]+)/){ 19 | $msg->{allow_plugin} = 0; 20 | my ($p,$v) = ($1,$2); 21 | my $doc = ''; 22 | my $command; 23 | if($v eq q{$'}){ 24 | $command = qq{$PERLDOC_COMMAND -Tt -$p "$v" 2>&1|}; 25 | } 26 | else{ 27 | $command = qq{$PERLDOC_COMMAND -Tt -$p '$v' 2>&1|}; 28 | } 29 | open PERLDOC,$command or $doc = '@灰灰 run perldoc fail'; 30 | while(){ 31 | last if $.>10; 32 | $doc .= $_; 33 | } 34 | close PERLDOC; 35 | $doc=~s/\n*$/...\n/; 36 | if($p eq 'f'){ 37 | if($doc=~/^No documentation for perl function/){ 38 | $doc .= "http://perldoc.perl.org/index-functions.html"; 39 | } 40 | else{ 41 | $doc .= "See More: http://perldoc.perl.org/functions/$v.html"; 42 | } 43 | } 44 | elsif($p eq 'v'){ 45 | $doc .= "See More: http://perldoc.perl.org/perlvar.html"; 46 | } 47 | 48 | $client->reply_message($msg,$doc) if $doc; 49 | return 0; 50 | } 51 | 52 | elsif($msg->{content} =~ /perldoc\s+((\w+::)*\w+)/ or $msg->{content} =~ /((\w+::)+\w+)/){ 53 | $msg->{allow_plugin} = 0; 54 | my $module = $1; 55 | my $is_perldoc = $msg->{content}=~/perldoc/; 56 | if(!$is_perldoc and exists $last_module_time{$msg->{type}}{$msg->{from_uin}}{$module} and time - $last_module_time{$msg->{type}}{$msg->{from_uin}}{$module} < 1800){ 57 | return 0; 58 | } 59 | my $metacpan_module_api = 'http://api.metacpan.org/v0/module/'; 60 | my $metacpan_pod_api = 'http://api.metacpan.org/v0/pod/'; 61 | 62 | my $cache = $client->{cache_for_metacpan}->retrieve($module); 63 | if(defined $cache){ 64 | $client->reply_message($msg,$cache->{doc}); 65 | $last_module_time{$msg->{type}}{$msg->{from_uin}}{$module} = time; 66 | return 0; 67 | } 68 | $client->{asyn_ua}->get($metacpan_module_api . $module,(),sub{ 69 | my $response = shift; 70 | my $doc; 71 | my $json; 72 | my $code; 73 | if($client->{debug}){ 74 | print "GET " . $metacpan_module_api . $module,"\n"; 75 | #print $response->content; 76 | } 77 | eval{ $json = JSON->new->utf8->decode($response->content);}; 78 | unless($@){ 79 | if($json->{code} == 404){ 80 | return 0; 81 | #$doc = "模块名称: $module ($json->{message})" ; 82 | #$code = 404; 83 | 84 | #$client->{cache_for_metacpan}->store($module,{code=>$code,doc=>$doc},604800); 85 | #$client->reply_message($msg,$doc) ; 86 | #$last_module_time{$msg->{type}}{$msg->{from_uin}}{$module} = time; 87 | } 88 | else{ 89 | $code = 200; 90 | my $author = $json->{author}; 91 | my $version = $json->{version}; 92 | #my $date = $json->{date}; 93 | my $abstract= $json->{abstract}; 94 | my $podlink = 'https://metacpan.org/pod/' . $module; 95 | $doc = 96 | "模块: $module\n" . 97 | "版本: $version\n" . 98 | "作者: $author\n" . 99 | "简述: $abstract\n" . 100 | "链接: $podlink\n" 101 | ; 102 | print "GET " . $metacpan_pod_api . $module,"\n" if $client->{debug}; 103 | $client->{asyn_ua}->get($metacpan_pod_api . $module,(Accept=>"text/plain"),sub{ 104 | my $res = shift; 105 | my ($SYNOPSIS) = $res->content()=~/^SYNOPSIS$(.*?)^[A-Za-z]+$/ms; 106 | if($SYNOPSIS){ 107 | $doc .= "用法概要: $SYNOPSIS\n" ; 108 | $doc=~s/\n+$//; 109 | $doc = truncate($doc,max_bytes=>1000,max_lines=>30); 110 | } 111 | $client->{cache_for_metacpan}->store($module,{code=>$code,doc=>$doc},604800); 112 | $client->reply_message($msg,$doc); 113 | $last_module_time{$msg->{type}}{$msg->{from_uin}}{$module} = time; 114 | }); 115 | } 116 | } 117 | }); 118 | 119 | return 0; 120 | } 121 | 122 | return 1; 123 | } 124 | 125 | 1; 126 | -------------------------------------------------------------------------------- /lib/Webqq/Client/Method/_login1.pm: -------------------------------------------------------------------------------- 1 | use Digest::MD5 qw(md5 md5_hex); 2 | use Webqq::Client::Util qw(console); 3 | use Webqq::Encryption qw(pwd_encrypt pwd_encrypt_js); 4 | sub Webqq::Client::_login1{ 5 | console "尝试进行登录(阶段1)...\n"; 6 | my $self = shift; 7 | my $encrypt_method = $self->{encrypt_method} || "js"; 8 | my $ua = $self->{ua}; 9 | my $api_url = 'https://ssl.ptlogin2.qq.com/login'; 10 | my @headers = $self->{type} eq 'webqq'? (Referer => 'https://ui.ptlogin2.qq.com/cgi-bin/login?daid=164&target=self&style=5&mibao_css=m_webqq&appid=1003903&enable_qlogin=0&no_verifyimg=1&s_url=http%3A%2F%2Fweb2.qq.com%2Floginproxy.html&f_url=loginerroralert&strong_login=1&login_state=10&t=20140612002') 11 | : (Referer => 'https://ui.ptlogin2.qq.com/cgi-bin/login?daid=164&target=self&style=16&mibao_css=m_webqq&appid=501004106&enable_qlogin=0&no_verifyimg=1&s_url=http%3A%2F%2Fw.qq.com%2Fproxy.html&f_url=loginerroralert&strong_login=1&login_state=10&t=20131024001') 12 | ; 13 | 14 | my $passwd; 15 | 16 | if($self->{type} eq 'webqq'){ 17 | $md5_salt = eval qq{"$self->{qq_param}{md5_salt}"}; 18 | $passwd = pack "H*",$self->{qq_param}{pwd}; 19 | $passwd = uc md5_hex( uc(md5_hex( $passwd . $md5_salt)) . uc( $self->{qq_param}{verifycode} ) ); 20 | 21 | } 22 | else{ 23 | eval{ 24 | if($encrypt_method eq "perl"){ 25 | $passwd = pwd_encrypt($self->{qq_param}{pwd},$self->{qq_param}{md5_salt},$self->{qq_param}{verifycode},1) ; 26 | } 27 | else{ 28 | $passwd = pwd_encrypt_js($self->{qq_param}{pwd},$self->{qq_param}{md5_salt},$self->{qq_param}{verifycode},1) ; 29 | } 30 | }; 31 | if($@){ 32 | console "客户端加密算法执行错误：$@\n"; 33 | return $encrypt_method eq "perl"?-2:-3; 34 | } 35 | } 36 | my $query_string_ul = $self->{type} eq 'webqq'? 'http%3A%2F%2Fweb2.qq.com%2Floginproxy.html%3Flogin2qq%3D1%26webqq_type%3D10' 37 | : 'http%3A%2F%2Fw.qq.com%2Fproxy.html%3Flogin2qq%3D1%26webqq_type%3D10' 38 | ; 39 | my $query_string_action = $self->{type} eq 'webqq' ? '3-14-15279' 40 | : '0-23-19230' 41 | ; 42 | 43 | 44 | my @query_string = ( 45 | u => $self->{qq_param}{qq}, 46 | p => $passwd, 47 | verifycode => $self->{qq_param}{verifycode}, 48 | webqq_type => 10, 49 | remember_uin => 1, 50 | login2qq => 1, 51 | aid => $self->{qq_param}{g_appid}, 52 | u1 => $query_string_ul, 53 | h => 1, 54 | ptredirect => 0, 55 | ptlang => 2052, 56 | daid => $self->{qq_param}{g_daid}, 57 | from_ui => 1, 58 | pttype => 1, 59 | dumy => undef, 60 | fp => 'loginerroralert', 61 | action => $query_string_action, 62 | mibao_css => $self->{qq_param}{g_mibao_css}, 63 | t => 1, 64 | g => 1, 65 | js_type => 0, 66 | js_ver => $self->{qq_param}{g_pt_version}, 67 | pt_vcode_v1 => 0, 68 | pt_verifysession_v1 => $self->{qq_param}{verifysession} || $self->search_cookie("verifysession"), 69 | 70 | ); 71 | if($self->{type} eq 'webqq'){ 72 | splice @query_string,-4,0,(pt_uistyle => $self->{qq_param}{g_style}); 73 | } 74 | else{ 75 | splice @query_string,-4,0,(login_sig => $self->{qq_param}{g_login_sig}); 76 | splice @query_string,-4,0,(pt_randsalt => $self->{qq_param}{isRandSalt} ); 77 | } 78 | 79 | my @query_string_pairs; 80 | push @query_string_pairs , shift(@query_string) . "=" . shift(@query_string) while(@query_string) ; 81 | 82 | for(my $i=1;$i<=$self->{ua_retry_times};$i++){ 83 | my $response = $ua->get($api_url.'?'.join("&",@query_string_pairs),@headers ); 84 | if($response->is_success){ 85 | print $response->content() if $self->{debug}; 86 | my $content = $response->content(); 87 | my %d = (); 88 | @d{qw( retcode unknown_1 api_check_sig unknown_2 status uin )} = $content=~/'(.*?)'/g; 89 | #ptuiCB('4','0','','0','您输入的验证码不正确，请重新输入。', '12345678'); 90 | #ptuiCB('3','0','','0','您输入的帐号或密码不正确，请重新输入。', '2735534596'); 91 | 92 | if($d{retcode} == 4){ 93 | console "您输入的验证码不正确，需要重新输入...\n"; 94 | return -1; 95 | } 96 | elsif($d{retcode} == 3){ 97 | if($encrypt_method eq "perl"){ 98 | return -2; 99 | } 100 | else{ 101 | console "您输入的帐号或密码不正确，客户端终止运行...\n"; 102 | $self->stop(); 103 | } 104 | } 105 | elsif($d{retcode} != 0){ 106 | console "$d{status}，客户端终止运行...\n"; 107 | $self->stop(); 108 | } 109 | $self->{qq_param}{api_check_sig} = $d{api_check_sig}; 110 | $self->{qq_param}{ptwebqq} = $self->search_cookie('ptwebqq'); 111 | return 1; 112 | } 113 | } 114 | return 0; 115 | } 116 | 1; 117 | -------------------------------------------------------------------------------- /lib/Webqq/UserAgent.pm: -------------------------------------------------------------------------------- 1 | package Webqq::UserAgent; 2 | 3 | use AnyEvent::HTTP (); 4 | use HTTP::Cookies (); 5 | use HTTP::Request (); 6 | use HTTP::Request::Common (); 7 | use HTTP::Response (); 8 | 9 | sub new { 10 | my $class = shift; 11 | my %p = @_; 12 | return bless { 13 | agent => $p{agent} || $AnyEvent::HTTP::USERAGENT . ' AnyEvent-UserAgent/' . $VERSION , 14 | cookie_jar => $p{cookie_jar} || HTTP::Cookies->new, 15 | max_redirects => $p{max_redirects} || 5, 16 | inactivity_timeout => $p{inactivity_timeout} || 20, 17 | request_timeout => $p{request_timeout} || 0 18 | },$class; 19 | } 20 | sub request { 21 | my $cb = pop(); 22 | my ($self, $req, %opts) = @_; 23 | $self->_request($req, \%opts, sub { 24 | $self->_response($req, @_, $cb); 25 | }); 26 | } 27 | 28 | sub get { _make_request(GET => @_) } 29 | sub head { _make_request(HEAD => @_) } 30 | sub put { _make_request(PUT => @_) } 31 | sub delete { _make_request(DELETE => @_) } 32 | sub post { _make_request(POST => @_) } 33 | 34 | sub _make_request { 35 | my $cb = pop(); 36 | my $meth = shift(); 37 | my $self = shift(); 38 | 39 | no strict 'refs'; 40 | $self->request(&{'HTTP::Request::Common::' . $meth}(@_), $cb); 41 | } 42 | 43 | sub _request { 44 | my ($self, $req, $opts, $cb) = @_; 45 | 46 | my $uri = $req->uri; 47 | my $hdrs = $req->headers; 48 | 49 | unless ($hdrs->user_agent) { 50 | $hdrs->user_agent($self->{agent}); 51 | } 52 | 53 | if ($uri->can('userinfo') && $uri->userinfo && !$hdrs->authorization) { 54 | $hdrs->authorization_basic(split(':', $uri->userinfo, 2)); 55 | } 56 | if ($uri->scheme) { 57 | $self->{cookie_jar}->add_cookie_header($req); 58 | } 59 | 60 | for (qw(max_redirects inactivity_timeout request_timeout)) { 61 | $opts->{$_} = $self->{$_} unless exists($opts->{$_}); 62 | } 63 | 64 | my ($grd, $tmr); 65 | 66 | if ($opts->{request_timeout}) { 67 | $tmr = AE::timer $opts->{request_timeout}, 0, sub { 68 | undef($grd); 69 | $cb->($opts, undef, {Status => 597, Reason => 'Request timeout'}); 70 | }; 71 | } 72 | $grd = AnyEvent::HTTP::http_request( 73 | $req->method, 74 | $req->uri, 75 | headers => {map { $_ => $hdrs->header($_) } $hdrs->header_field_names}, 76 | body => $req->content, 77 | recurse => 0, 78 | timeout => $opts->{inactivity_timeout}, 79 | (map { $_ => $opts->{$_} } grep { exists($opts->{$_}) } 80 | qw(proxy tls_ctx session timeout on_prepare tcp_connect on_header 81 | on_body want_body_handle persistent keepalive handle_params)), 82 | sub { 83 | undef($grd); 84 | undef($tmr); 85 | $cb->($opts, @_); 86 | } 87 | ); 88 | } 89 | 90 | sub _response { 91 | my $cb = pop(); 92 | my ($self, $req, $opts, $body, $hdrs, $prev, $count) = @_; 93 | 94 | my $res = HTTP::Response->new(delete($hdrs->{Status}), delete($hdrs->{Reason})); 95 | 96 | $res->request($req); 97 | $res->previous($prev) if $prev; 98 | 99 | delete($hdrs->{URL}); 100 | if (defined($hdrs->{HTTPVersion})) { 101 | $res->protocol('HTTP/' . delete($hdrs->{HTTPVersion})); 102 | } 103 | if (my $hdr = $hdrs->{'set-cookie'}) { 104 | # Split comma-concatenated "Set-Cookie" values. 105 | # Based on RFC 6265, section 4.1.1. 106 | local @_ = split(/,([\w.!"'%\$&*+-^`]+=)/, ',' . $hdr); 107 | shift(); 108 | my @val; 109 | push(@val, join('', shift(), shift())) while @_; 110 | $hdrs->{'set-cookie'} = \@val; 111 | } 112 | if (keys(%$hdrs)) { 113 | $res->header(%$hdrs); 114 | } 115 | if ($res->code >= 590 && $res->code <= 599 && $res->message) { 116 | if ($res->message eq 'Connection timed out') { 117 | $res->message('Inactivity timeout'); 118 | } 119 | unless ($res->header('client-warning')) { 120 | $res->header('client-warning' => $res->message); 121 | } 122 | } 123 | if (defined($body)) { 124 | $res->content_ref(\$body); 125 | } 126 | $self->{cookie_jar}->extract_cookies($res); 127 | 128 | my $code = $res->code; 129 | 130 | if ($code == 301 || $code == 302 || $code == 303 || $code == 307 || $code == 308) { 131 | $self->_redirect($req, $opts, $code, $res, $count, $cb); 132 | } 133 | else { 134 | $cb->($res); 135 | } 136 | } 137 | 138 | sub _redirect { 139 | my ($self, $req, $opts, $code, $prev, $count, $cb) = @_; 140 | 141 | unless (defined($count) ? $count : ($count = $opts->{max_redirects})) { 142 | $prev->header('client-warning' => 'Redirect loop detected (max_redirects = ' . $opts->{max_redirects} . ')'); 143 | $cb->($prev); 144 | return; 145 | } 146 | 147 | my $meth = $req->method; 148 | my $proto = $req->uri->scheme; 149 | my $uri = $prev->header('location'); 150 | 151 | $req = $req->clone(); 152 | $req->remove_header('cookie'); 153 | if (($code == 302 || $code == 303) && !($meth eq 'GET' || $meth eq 'HEAD')) { 154 | $req->method('GET'); 155 | $req->content(''); 156 | $req->remove_content_headers(); 157 | } 158 | { 159 | # Support for relative URL for redirect. 160 | # Not correspond to RFC. 161 | local $URI::ABS_ALLOW_RELATIVE_SCHEME = 1; 162 | my $base = $prev->base; 163 | $uri = $HTTP::URI_CLASS->new(defined($uri) ? $uri : '', $base)->abs($base); 164 | } 165 | $req->uri($uri); 166 | if ($proto eq 'https' && $uri->scheme eq 'http') { 167 | # Suppress 'Referer' header for HTTPS to HTTP redirect. 168 | # RFC 2616, section 15.1.3. 169 | $req->remove_header('referer'); 170 | } 171 | 172 | $self->_request($req, $opts, sub { 173 | $self->_response($req, @_, $prev, $count - 1, sub { return $cb->(@_); }); 174 | }); 175 | } 176 | 177 | 178 | 1; 179 | 180 | 181 | __END__ 182 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | 版本更新记录: 2 | 2015-09-24 Webqq::Client v8.5.3 3 | 1）该模块停止使用和开发 4 | 2）修复代码产生的警告 5 | 2015-09-17 Webqq::Client v8.5.2 6 | 1）修复add_job无法执行回调函数的bug 感谢 林海 7 | 8 | 2015-09-14 Webqq::Client v8.5.1 9 | 1）BUG修复rt.cpan.org#107067 10 | 11 | 2015-06-19 Webqq::Client v8.5.0 12 | 1）修复pfqq版本号错误 13 | 2）修复Webqq/Message.pm文件代码拼写错误 感谢 arrow.wang 的反馈 14 | 15 | 2015-06-02 Webqq::Client v8.4.9 16 | 1）修复登录死循环问题 17 | 2）MsgSync插件对发送到irc的消息进行截断防止大量发送被服务器踢下线 18 | 19 | 2015-05-28 Webqq::Client v8.4.8 20 | 1）Perlcode插件执行代码时默认导入say函数 21 | 2）客户端登录加密算法默认使用纯Perl计算方式，当出现失败时或错误时会自动使用js的方式重试 22 | 3）客户端增加一个encrypt_method的属性，支持设置默认的登录加密算法方式 23 | 4）修复长时间登录导致客户端无法更新好友信息、群信息的bug 24 | 5）完善MsgSync模块 25 | 26 | 2015-04-23 Webqq::Client v8.4.7 27 | 1）修复依赖模块信息 28 | 29 | 2015-04-23 Webqq::Client v8.4.6 30 | 1）修复Makefile.PL错误 31 | 2）将Webqq::Encryption单独发布 32 | 33 | 2015-04-23 Webqq::Client v8.4.5 34 | 1）修复输入正确验证码仍然提示验证码错误的bug 感谢[PERL学习交流 @乀﹒安乐，仅此那么一分钟]的反馈 35 | 2）修复测试脚本注释错误 36 | 3）增加模块的别名pfqq 37 | 4）修复获取qq号，群号等信息如果存在多个相同昵称导致错误的bug 38 | 39 | 2015-04-18 Webqq::Client v8.4.4 40 | 1）修复客户端定时更新群组信息未生效的bug 41 | 42 | 2015-04-17 Webqq::Client v8.4.3 43 | 1）支持利用Webqq::Qun来获取群号码、群成员QQ号、好友QQ号 44 | 2）Openqq的api接口支持使用群号码和好友qq号码来指定发送对象 45 | 3）修复Openqq的api自己给自己发送消息导致死循环的bug 46 | 4）修复SmartReply的识别逻辑错误，感谢[perl技术 @kk]反馈 47 | 48 | 2015-03-31 Webqq::Client v8.4.2 49 | 1）新增Webqq::Encryption::TEA::Perl模块，TEA算法纯perl实现 50 | 51 | 2015-03-31 Webqq::Client v8.4.1 52 | 1）支持Crypt:::RSA模块进行RSA计算，该模块是纯Perl编写，更易安装 53 | 54 | 2015-03-31 Webqq::Client v8.4 55 | 1）新增Webqq::Encryption模块，将登录加密中涉及到的TEA/RSA算法进行了分离 56 | 2）可以通过安装Crypt::OpenSSL::RSA/Crypt::OpenSSL::Bignum/MIME::Base64模块来提升计算速度10倍以上 57 | 58 | 2015-03-11 Webqq::Client v8.3.1 59 | 1）修复少了文档错误 60 | 61 | 2015-03-11 Webqq::Client v8.3 62 | 1）Plugin函数使用eval执行，防止插件出错导致整个程序退出 63 | 2）更新获取好友列表和群列表的hash函数 64 | 由于腾讯更新了hash算法，导致旧版本无法获取到好友信息和群信息，请尽快更新到此版本 65 | 66 | 2015-03-10 Webqq::Client v8.2.1 67 | 1）使用git tag进行版本号管理 68 | 2）修复pod文档错误 感谢 @wxg 反馈 69 | 3）修复SmartReply插件api接口获取数据失败后导致主程序退出的bug 70 | 71 | 2015-02-22 Webqq::Client v8.2 72 | 1）Openqq插件进一步完善，提供获取信息、发送消息完整api 73 | 2）pod文档增加Openqq api的详细说明 74 | 75 | 2015-02-10 Webqq::Client v8.1 76 | 1）新增Webqq::Client::Plugin::Openqq插件，使用PSGI+Twiggy框架，提供RESTful API 77 | 2）新增$client->ready()/stop()/exit()/Webqq::Client::RUN()来支持单进程多账号模式 78 | 3）新增on_ready()回调，在多账号模式下替代原有的on_run()回调 79 | 80 | 2015-02-10 Webqq::Client v8.0 81 | 1）new()/login()新增security参数，security=>1表示发送/接收消息使用https加密 82 | 83 | 2015-02-09 Webqq::Client v7.9 84 | 1）新增最近联系人列表功能 感谢@wxg的补丁 85 | 2）用户、好友、群、讨论组增加客户端类型(client_type)属性 感谢@wxg的补丁 86 | 3）修复CpanRecentModule模块当发现新模块时进入死循环的bug 87 | 88 | 2015-02-07 Webqq::Client v7.8 89 | 1）个人、群、讨论组成员增加状态属性(state) 90 | 2）新增对buddies_status_change消息类型的处理 91 | 2）新增on_friend_change_state回调，好友状态变化实时提醒 92 | 93 | 2015-02-06 Webqq::Client v7.7 94 | 1）修复发送中文消息时严重bug导致发送消息为空 95 | 96 | 2015-02-04 Webqq::Client v7.6 97 | 1）修复表情消息处理错误 98 | 2）使用List::Util 提供的first函数优化代码逻辑 99 | 100 | 2015-02-04 Webqq::Client v7.5 101 | 1）大量bug修复和代码逻辑优化 102 | 2）新增讨论组功能支持（由于腾讯限制，目前仅能接收讨论组消息，无法发送） 103 | 3）支持讨论组临时消息 104 | 4）增加设置在线状态功能，感谢@wxg的补丁 105 | 106 | 2015-01-26 Webqq::Client v7.4 107 | 1）新增$client->{is_first_login}属性，用于识别是否是首次登录 108 | 2）修复relogin清空cookie时严重错误，该错误可能会导致程序异常退出 109 | 3）修复on_new_group在错误的时机被执行的bug 110 | 4）新增客户端接收消息失败次数限制，超过失败次数自动重连 111 | 5）$client->_relink()方法重新连接失败后会改为重新登录 112 | 113 | 2015-01-23 Webqq::Client v7.3 114 | 1）新增$client->_relink()方法，区分重新登录、重新连接两种行为 115 | 2）修复on_login回调在login之后不能马上发送消息的缺陷 116 | 3）完善$client->_recv_message()对异常响应的处理 117 | 4）$client->_cookie_proxy()方法嵌入到$client->_login2()中执行 118 | 5）修复$client->_login2()请求参数错误 119 | 120 | 2015-01-22 Webqq::Client v7.2 121 | 1）修复relogin时on_new_group回调存在的bug 122 | 2）新增Webqq::UserAgent代替AnyEvent::UserAgent减少模块依赖 123 | 124 | 2015-01-16 Webqq::Client v7.1 125 | 1）Webqq::Client::Cache新增->delete()的方法 126 | 2）新增_detect_new_group_member2方法，用于发现新增成员 127 | 3）新增_detect_loss_group_member方法，用于发现退群成员 128 | 4）客户端定时更新群信息 129 | 5）新增on_loss_group_member回调 130 | 131 | 2015-01-12 Webqq::Client v7.0 132 | 1）新增cookie跨域私有方法$client->_cookie_proxy() 133 | 2）新增下载好友自定义图片私有方法$client->_get_offpic() 134 | 3）新增下载好友自定义图片回调$client->on_receive_offpic 135 | 4）$msg->{raw_content}将cface和offpic进行区分 136 | 5）修复Perlcode插件空白命令仍然执行的bug 137 | 6）修复SmartReply空白内容仍然执行api查询的bug 138 | 139 | 2015-01-03 Webqq::Client v6.9 140 | 1）CpanRecentModule插件bug修复 141 | 2）客户端消息发送间隔默认修改为2s 142 | 3）增加$client->get_dwz()方法，生成url对应的短地址 143 | 144 | 2014-12-31 Webqq::Client v6.8 145 | 1）修复Webqq::Client::Cron变量重复声明的错误 146 | 147 | 2014-12-31 Webqq::Client v6.7 148 | 1）完善客户端消息发送间隔控制，可以设置$client->{send_interval}，默认1s 149 | 150 | 2014-12-29 Webqq::Client v6.6 151 | 1）进一步完善文档 152 | 2）修复update_group_info多次调用导致群信息重复的bug 153 | 154 | 2014-12-28 Webqq::Client v6.5 155 | 1）MakeFile.PL增加Time::Piece/Time::Seconds依赖模块 156 | 157 | 2014-12-28 Webqq::Client v6.4 158 | 1）客户端search_group/search_friend/search_member_in_group功能进行优化 159 | 2）客户端on_new_friend/on_new_group/on_new_group_member回调优化 160 | 161 | 2014-12-24 Webqq::Client v6.3 162 | 1）修复add_job会导致程序出现死循环的严重bug 163 | 164 | 2014-12-24 Webqq::Client v6.2 165 | 1）修复on_input_img_verifycode文档错误 166 | 167 | 2014-12-24 Webqq::Client v6.1 168 | 1）取消MakeFile中的DateTime依赖 169 | 170 | 2014-12-24 Webqq::Client v6.0 171 | 1）修改登陆异常时的报错信息 172 | 2）_login1()返回异常时，打印错误原因 173 | 3）Webqq::Client::Cron取消对DateTime的依赖，改为Time::Piece和Time::Seconds 174 | 175 | 2014-12-23 Webqq::Client v5.9 176 | 1）发送消息方法调用更加便捷 177 | 2）调整一些demo示例代码 178 | 179 | 2014-12-23 Webqq::Client v5.8 180 | 1）create_sess_msg()方法修复主动发送群临时消息的bug 181 | 2）ShowMsg插件可以打印群临时消息所属的群名称 182 | 3）PostImgVerifycode修复提交验证码后页面响应为空的bug 183 | 4）修复pod里密码md5加密容易引起歧义的描述 184 | 185 | 2014-12-19 Webqq::Client v5.7 186 | 1）修复LinkInfo/SmartReply插件的多出bug 187 | 2）完善Perlcode插件的资源限制 188 | 3）新增$msg->{raw_conent}属性用于获取更多原始消息内容 189 | 4）新增javascript运行测试脚本 190 | 5）优化javascript加载速度 191 | 192 | 2014-12-17 Webqq::Client v5.6 193 | 1）客户端验证码输错会进行多次重试 194 | 2）支持smartqq登录密码加密算法 195 | webqq采用的只是多重md5带盐加密 196 | 而smartqq采用的是 md5带盐加密+RSA+Base64 三重组合 197 | 采用了JE模块直接perl中运行javascript代码 198 | 要运行客户端请确保你已经安装了该模块 199 | 3）新增LinkInfo的插件，获取url的标题和正文内容 200 | 201 | 2014-12-15 Webqq::Client v5.5 202 | 1）查询增加缓存机制，提高查询速度 203 | 2）修复on_new_group_member/on_new_friend回调在某些情况下无法正常触发的bug 204 | 3）增加get_single_long_nick()的方法用于获取指定qq用户的个性签名 205 | 206 | 2014-12-09 Webqq::Client v5.4 207 | 1）登录过程增加请求失败重试机制 208 | 2）新增Webqq::Client::Plugin::PicLimit插件，对群里发图数量太多警告 209 | 210 | 2014-12-09 Webqq::Client v5.3 211 | 1）修复ShowMsg插件bug 212 | 2）修复发送消息重试机制失效的bug 213 | 214 | 2014-12-09 Webqq::Client v5.2 215 | 1）修复search_member_in_group()存在的bug导致无法正常获取新入群成员信息 216 | 2）_get_group_info()在debug模式下打印的调试信息进行了精简 217 | 218 | 2014-12-09 Webqq::Client v5.1 219 | 1）调整pod文档格式 220 | 2）回调函数使用eval包裹 221 | 222 | 2014-12-06 Webqq::Client v5.0 223 | 1）Webqq::Client::App::*重新更名为Webqq::Client::Plugin:: 224 | 2）新增Webqq::Client::Plugin模块，用于管理插件 225 | 3）新增$msg->{allow_plugin}属性用于插件之间协作 226 | 4）更新对应的pod文档 227 | 5）demo示例代码更新 228 | 229 | 2014-12-04 Webqq::Client v4.9 230 | 1）插件支持执行链的功能，在插件链上的每一个插件 231 | 都可以选择是否要继续执行后续的插件 232 | 2）少量细节完善 233 | 234 | 2014-12-04 Webqq::Client v4.8 235 | 1）完善on_new_gropu_memner相关的pod文档 236 | 2）新增Webqq::Client::App::HelloGril插件 237 | 3）修复on_new_gropu_memner回调的bug 238 | 4）修复无法获取群成员信息时导致反复获取的bug 239 | 240 | 2014-11-28 Webqq::Client v4.7 241 | 1）完善pod文档 242 | 2）Webqq::Client::App::SmartReply限制条件更加严格 243 | 3）删除$client->_get_msg_tip() 244 | 4）接收到的好友消息增加$msg->from_city() 245 | 246 | 2014-11-28 Webqq::Client v4.6 247 | 1）修复客户端发送消息失败无法正常返回状态的bug 248 | 2）cpan模块信息查询支持显示SYNOPSIS 249 | 3）perlcode的执行方式更加自由灵活，支持perl -e '' 250 | 4）每个$msg都增加一个ttl值，在消息发送过程中ttl值会递减 251 | 当减少到0则会被消息队列丢弃 252 | 5）智能回复会增加消息发送者所在城市信息 253 | 6）修复perlcode识别代码错误的bug 254 | 7）Webqq::Client::App::SmartReply增加每分钟次数限制 255 | 256 | 2014-11-26 Webqq::Client v4.5 257 | 1）正确处理客户端收到的陌生人消息 258 | 2）只有在群消息时才进行截断 259 | 3）系统开启关闭消息时也通过回复消息进行状态反馈 260 | 4）修复模块查询信息细节 261 | 5）Webqq::Client::App::Perldoc指令进行优化 262 | 263 | 2014-11-26 Webqq::Client v4.4 264 | 1）为配合Perl的MakeFile，src文件夹重命名为lib 265 | 2）完善make test测试脚本 266 | 267 | 2014-11-26 Webqq::Client v4.3 268 | 1）整合webqq和smartqq，现在可以通过$client->new(type=>...);进行选择 269 | type=>"smartqq"或者type=>"webqq" 270 | 2）目前api接口获取群信息时会出现无法获取到群成员情况，代码进行了适配处理 271 | 3）修复了Webqq::Client::App::Perldoc中关于模块查询信息bug 272 | 4）Webqq::Client::App::SmartReply回复消息时会按照80%的概率先@对方 273 | 274 | 2014-11-24 Webqq::Client v4.2 275 | 1）修复Makefile错误，感谢[perl技术 @kk] 276 | 2）版本号形式从 v4.2 改为 "4.2"; 277 | 3）新增Webqq::Client::App::SendMsgControl 278 | 可以通过"-shutdown","-reactive"指令来关闭和开启消息发生功能 279 | 4）模块信息查询功能5分钟内只提醒一次 280 | 281 | 2014-11-24 Webqq::Client v4.1 282 | 1）支持perldoc 模块名查询cpan模块信息 283 | 2）支持自动识别聊天记录中的模块名 查询相关信息 284 | 3）识别perldoc指令不再要求精确匹配/^perldoc/ 285 | 4）增加模块查询信息缓存机制，提高响应速度 286 | 287 | 2014-11-23 Webqq::Client v4.0 288 | 1）客户端支持探测新成员或新好友，并自动更新客户端数据库 289 | 2）新增on_new_group() on_new_group_member on_new_friend() 回调 290 | 291 | 2014-11-21 Webqq::Client v3.9 292 | 1）新增Webqq::Client::App::SmartReply模块，智能回复消息 293 | 294 | 2014-11-21 Webqq::Client v3.8 295 | 1）修复客户端数据库存储bug 296 | 2）新增Webqq::Client::App::ClientStore模块，便于将客户端数据库存储到文件 297 | 3）修复Webqq::Client::App::PostImgVerfcode提交验证码后没有给出任何提示的bug 298 | 299 | 2014-11-21 Webqq::Client v3.7 300 | 1）增加系统表情文字显示支持，系统表情会以类似[微笑]的形式打印 301 | 2）修复查询信息无法正常缓存的bug 302 | 303 | 2014-11-20 Webqq::Client v3.6 304 | 1）修复客户端接收到临时消息后停止接收消息的bug 305 | 2）修复临时消息查找陌生人信息无法缓存问题 306 | 307 | 2014-11-20 Webqq::Client v3.5 308 | 1）demo/console_message.pl中的fromat_msg使用Webqq::Client::App::ShowMsg替换 309 | 2）Webqq::Client::App::ShowMsg进一步完善 310 | 3）延长拉去消息时间间隔 311 | 312 | 2014-11-19 Webqq::Client v3.4 313 | 1）修复Webqq::Message::_mk_ro_accessors严重bug，此bug会导致客户端获取到的消息信息错乱 314 | 新增Webqq::Message::_load_extra_accessor方法，客户端会在run()开始时执行 315 | 2）修改Webqq::Client::App::Msgstat::Report()排序算法 316 | 3）修改-Msgstat指令权限，只允许指定帐号使用 317 | 318 | 2014-11-19 Webqq::Client v3.3 319 | 1）修复-msgstat错误 320 | 2）增加大量文档说明,参加doc/Client.pod 321 | 322 | 2014-11-17 Webqq::Client v3.2 323 | 1）一定程度上屏蔽perlcode无限fork攻击，感谢[PERL学习交流 @Achilles/kl]指导 324 | 2）Webqq::Client::App::Perlcode/Webqq::Client::App::Perldoc不再执行超过一定时效的消息指令 325 | 3）Webqq::Client::App::ShowMsg使用qq号取代uin作为hash的key 326 | 327 | 2014-11-17 Webqq::Client v3.1 328 | 1）新增Webqq::Client::App::Msgstat统计群消息发言排行 329 | 2）修复图片、表情和文字混合的消息无法正常处理的bug 330 | 3）修复发送消息打印报错bug 331 | 4）修复Webqq::Client::App::Msgstat统计bug 332 | 5）完善Webqq::Client::App::Msgstat::Report()的输出格式 333 | 6）完善Webqq::Client::App::Msgstat::Report()群名片显示问题 334 | 7）增强-msgstat指令，支持-msgstat 数字 群名称调用形式 335 | 336 | 2014-11-17 Webqq::Client v3.0 337 | 1）Webqq::Client::App::ShowMsg支持打印发送和接收消息 338 | 2）文档结构调整，增加了一些MakeFile和POD支持(未完善) 339 | 3）修复format_msg()打印结果不对齐的bug 340 | 341 | 2014-11-07 Webqq::Client v2.9 342 | 1）修复收到下线通知消息时客户端处理错误，感谢[perl技术 @路人丙]的测试反馈 343 | 2）增加Webqq::Client::App::ShowMsg应用，可以方便打印收到的消息 344 | 345 | 2014-11-07 Webqq::Client v2.8 346 | 1）Webqq::Client::App::Perlcode支持自动查找本机perldoc路径 347 | 2）Webqq::Client::App::Perldoc支持自动查找本机perl路径 348 | 3）Webqq::Client::App::Perldoc/Webqq::Client::App::Perlcode运行在非linux系统报错退出 349 | 350 | 2014-11-03 Webqq::Client v2.7 351 | 1）新增Webqq::Client::Cron模块，支持定时执行回调 352 | 2）新增Webqq::Client::App::Msgstat应用，统计群内成员发送消息数量 353 | 354 | 2014-11-03 Webqq::Client v2.6 355 | 1）支持从本地socket接收发送消息指令 356 | 2）支持从QQ消息接收发送消息指令 357 | 358 | 2014-10-31 Webqq::Client v2.5 359 | 1）使用深拷贝彻底修复重新登录异常问题 360 | 361 | 2014-10-29 Webqq::Client v2.4 362 | 1）修复重新登录异常问题 363 | 364 | 2014-10-27 Webqq::Client v2.3 365 | 1）增加登录成功、输入验证码回调函数 366 | 2）支持在未连接TTY时将验证码通过邮件形式发送到指定邮箱， 367 | 可以在邮箱中点击链接直接完成验证码输入（方便在手机上随时收邮件输验证码） 368 | 通过这种方式可以避免QQ每隔一段时间被强迫下线无法在电脑前再次输入验证码的缺点 369 | 370 | 2014-10-23 Webqq::Client v2.2 371 | 1）修复因临时目录不存在出现chroot失败，导致有权限执行危险系统命令 372 | 2）其他少量细节完善 373 | 374 | 2014-09-28 Webqq::Client v2.1 375 | 1）增加定时更新群列表信息，群信息 376 | 2）群信息查询结果进行缓存 377 | 3）数据查询和数据更新进行了分离 378 | 4）消息发送添加发送间隔，腾讯webqq不允许短时间内发送次数过于频繁 379 | 380 | 2014-09-28 Webqq::Client v2.0 381 | 1）支持获取临时消息联系人信息 382 | 2）$msg消息结构采用AAG(Automated Accessor Generation)技术， 383 | 每个hash的key都自动产生一个对应的的方法， 384 | 即，你可以使用$msg->{key}或者$msg->key任意一种方式获取你想要的数据 385 | 如感兴趣，可以参见cpan Class::Accessor模块 386 | 3）修复更新导致无法正常发送消息问题 387 | 388 | 2014-09-27 Webqq::Client v1.9 389 | 1）修复获取好友信息列表时，如果设置了好友备注名称会导致程序抛出异常的bug 390 | 感谢来自[perl技术 @阳]的反馈 391 | 2）完善了一些感谢人员信息 392 | 393 | 2014-09-26 Webqq::Client v1.8 394 | 1）增加->relogin()方法，在系统提示需要重新登录时尝试自动重新登录或者重新连接 395 | 2）修复客户端login_state设置bug 396 | 3）修复perlcode可以写入和读取系统文件问题 397 | 398 | 2014-09-26 Webqq::Client v1.7 399 | 1）支持接收和回复群临时消息(sess_message) 400 | 2）由于机器人大部分情况下都是根据接收的消息进行回复，因此增加reply_message() 401 | 使得消息处理，更加便捷，传统的方式，你需要自己create_msg，再send_message 402 | 这种方式更适合主动发送消息，采用reply_message($msg,$content) 403 | 只需要传入接收消息结构和要发送的内容，即可回复消息，且不需要关心消息的具体类型 404 | 3）根据聊天信息中的perldoc和perlcode指令进行文档查询和执行perl代码，源码公布 405 | 有兴趣可以参考: 406 | Webqq::Client::App::Perldoc 407 | Webqq::Client::App::Perlcode 408 | 后续会考虑形成中间件的开发框架，让更多的人参与,开发更多有趣的中间件 409 | 410 | 2014-09-18 Webqq::Client v1.6 411 | 1）修改发送消息数据编码，提高发送消息可靠些 412 | 413 | 2014-09-18 Webqq::Client v1.5 414 | 1）增加心跳检测 415 | 2）发送群消息增加一个Origin的HTTP请求头希望可以解决群消息偶尔发送不成功问题 416 | 417 | 2014-09-17 Webqq::Client v1.4 418 | 1）修复图片和表情无法正常显示问题，现在图片和表情会被转为文本形式 [图片][系统表情] 419 | 2）改进发送群消息机制，通过群消息group_code对应的gid再进行群消息发送 420 | 3）增加Webqq::Client::Cache模块，用于缓存一些经常需要使用的信息，避免时时查询 421 | 4）增加获取个人信息、好友信息、群信息、群成员信息功能 422 | 5）增加查询好友QQ号码功能 423 | 6）增加注销功能，程序运行后使用CTRL+C退出时，会自动完成注销 424 | 7）增加对强迫下线消息的处理 425 | ---- 426 | 当前发现的一些BUG： 427 | 1）再一次消息接收中如果包含多个消息，可能会导致只处理第一个消息，其他消息丢失 428 | 2）偶尔会出现发送群消息提示成功，但对方无法接收到的问题（可能和JSON编码有关） 429 | 430 | 2014-09-14 Webqq::Client v1.3 431 | 1）添加一些代码注释 432 | 2）demo/*.pl示例代码为防止打印乱码，添加终端编码自适应 433 | 3）添加Webqq::Message::Queue消息队列，实现接收消息、处理消息、发送消息等函数解耦 434 | 435 | 2014-09-14 Webqq::Client v1.2 436 | 1）源码改为UTF8编写，git commit亦采用UTF8字符集，以兼容github显示 437 | 2）优化JSON数据和perl内部数据格式之间转换，更好的兼容中文 438 | 3）修复debug下的打印错误（感谢 [PERL学习交流 @卖茶叶perl高手] 的bug反馈） 439 | 4）新增demo/console_message.pl示例代码，把接收到的普通消息和群消息打印到终端 440 | 441 | 2014-09-12 Webqq::Client v1.1 442 | 1）debug模式下支持打印send_message，send_group_message的POST提交数据，方便调试 443 | 2）修复了无法正常发送中文问题 444 | 3）修复了无法正常发送包含换行符的内容 445 | 4) on_receive_message/on_send_message改为是lvalue方法，以支持getter和setter方式 446 | 447 | -------------------------------------------------------------------------------- /lib/Webqq/Message.pm: -------------------------------------------------------------------------------- 1 | package Webqq::Message; 2 | use Webqq::Message::Face; 3 | use JSON; 4 | use Encode; 5 | use Webqq::Client::Util qw(console code2client); 6 | use Scalar::Util qw(blessed); 7 | sub reply_message{ 8 | my $client = shift; 9 | my $msg = shift; 10 | my $content = shift; 11 | unless(blessed($msg)){ 12 | console "输入的msg数据非法\n"; 13 | return 0; 14 | } 15 | if($msg->{type} eq 'message'){ 16 | $client->send_message( 17 | $client->create_msg(to_uin=>$msg->{from_uin},content=>$content) 18 | ); 19 | } 20 | elsif($msg->{type} eq 'group_message'){ 21 | $client->send_group_message( 22 | $client->create_group_msg( 23 | to_uin=>$msg->{from_uin}, 24 | content=>$content, 25 | group_code=>$msg->{group_code} 26 | ) 27 | ); 28 | } 29 | elsif($msg->{type} eq 'discuss_message'){ 30 | $client->send_discuss_message( 31 | $client->create_discuss_msg( 32 | to_uin =>$msg->{did} || $msg->{from_uin}, 33 | content =>$content, 34 | ) 35 | ); 36 | } 37 | elsif($msg->{type} eq 'sess_message'){ 38 | #群临时消息 39 | if($msg->{via} eq 'group'){ 40 | $client->send_sess_message( 41 | $client->create_sess_msg( 42 | to_uin => $msg->{from_uin}, 43 | content => $content, 44 | group_code => $msg->{group_code}, 45 | gid => $msg->{gid}, 46 | ) 47 | ); 48 | } 49 | #讨论组临时消息 50 | elsif($msg->{via} eq 'discuss'){ 51 | $client->send_sess_message( 52 | $client->create_sess_msg( 53 | to_uin => $msg->{from_uin}, 54 | content => $content, 55 | did => $msg->{did}, 56 | ) 57 | ); 58 | } 59 | } 60 | 61 | } 62 | sub create_sess_msg{ 63 | my $client = shift; 64 | return $client->_create_msg(@_,type=>'sess_message'); 65 | } 66 | sub create_group_msg{ 67 | my $client = shift; 68 | return $client->_create_msg(@_,type=>'group_message'); 69 | } 70 | sub create_msg{ 71 | my $client = shift; 72 | return $client->_create_msg(@_,type=>'message'); 73 | } 74 | sub create_discuss_msg{ 75 | my $client = shift; 76 | return $client->_create_msg(@_,type=>'discuss_message'); 77 | } 78 | sub _create_msg { 79 | my $client = shift; 80 | my %p = @_; 81 | $p{content} =~s/\r|\n/\n/g; 82 | my %msg = ( 83 | type => $p{type}, 84 | msg_id => $p{msg_id} || ++$client->{qq_param}{send_msg_id}, 85 | from_uin => $p{from_uin} || $client->{qq_param}{from_uin}, 86 | to_uin => $p{to_uin}, 87 | content => $p{content}, 88 | msg_class => "send", 89 | msg_time => time, 90 | cb => $p{cb}, 91 | ttl => 5, 92 | allow_plugin => 1, 93 | client => $client, 94 | ); 95 | if($p{type} eq 'sess_message'){ 96 | if(defined $p{group_code}){ 97 | $msg{group_code} = $p{group_code}; 98 | $msg{service_type} = 0; 99 | $msg{via} = 'group'; 100 | my $id = defined $p{gid}?$p{gid}:$client->search_group($p{group_code})->{gid}; 101 | $msg{group_sig} = $client->_get_group_sig($id,$p{to_uin},$msg{service_type}); 102 | } 103 | elsif(defined $p{gid}){ 104 | $msg{group_code} = $client->get_group_code_from_gid($p{gid}); 105 | $msg{service_type} = 0; 106 | $msg{via} = 'group'; 107 | my $id = $p{gid}; 108 | $msg{group_sig} = $client->_get_group_sig($id,$p{to_uin},$msg{service_type}); 109 | } 110 | elsif(defined $p{did}){ 111 | $msg{did} = $p{did}; 112 | $msg{service_type} = 1; 113 | $msg{via} = 'discuss'; 114 | $msg{group_sig} = $client->_get_group_sig($p{did},$p{to_uin},$msg{service_type}); 115 | } 116 | else{ 117 | console "create_sess_msg()必须设置group_code或者did\n"; 118 | return ; 119 | } 120 | } 121 | elsif($p{type} eq 'group_message'){ 122 | $msg{group_code} = $p{group_code}||$client->get_group_code_from_gid($p{to_uin}); 123 | $msg{send_uin} = $msg{from_uin}; 124 | } 125 | elsif($p{type} eq 'discuss_message'){ 126 | $msg{did} = $p{did} || $p{to_uin}; 127 | $msg{send_uin} = $msg{from_uin}; 128 | } 129 | my $msg_pkg = "\u$p{type}::Send"; 130 | $msg_pkg=~s/_(.)/\u$1/g; 131 | return $client->_mk_ro_accessors(\%msg,$msg_pkg); 132 | 133 | } 134 | 135 | sub _load_extra_accessor { 136 | *Webqq::Message::DiscussMessage::Recv::discuss_name = sub{ 137 | my $msg = shift; 138 | my $client = $msg->{client}; 139 | my $d = $client->search_discuss($msg->{did}); 140 | return defined $d?$d->{name}:undef ; 141 | }; 142 | *Webqq::Message::DiscussMessage::Recv::from_dname = sub{ 143 | my $msg = shift; 144 | my $client = $msg->{client}; 145 | my $d = $client->search_discuss($msg->{did}); 146 | return defined $d?$d->{name}:undef ; 147 | }; 148 | *Webqq::Message::DiscussMessage::Recv::from_qq = sub{ 149 | my $msg = shift; 150 | my $client = $msg->{client}; 151 | my $m = $client->search_member_in_discuss($msg->{did},$msg->{send_uin}); 152 | return defined $m?$m->{ruin}:$client->get_qq_from_uin($msg->{send_uin}); 153 | }; 154 | *Webqq::Message::DiscussMessage::Recv::from_nick = sub{ 155 | my $msg = shift; 156 | my $client = $msg->{client}; 157 | my $m = $client->search_member_in_discuss($msg->{did},$msg->{send_uin}); 158 | return defined $m?$m->{nick}:undef; 159 | }; 160 | 161 | *Webqq::Message::DiscussMessage::Send::discuss_name = sub{ 162 | my $msg = shift; 163 | my $client = $msg->{client}; 164 | my $d = $client->search_discuss($msg->{did}); 165 | return defined $d?$d->{name}:undef; 166 | }; 167 | *Webqq::Message::DiscussMessage::Send::to_dname = sub{ 168 | my $msg = shift; 169 | my $client = $msg->{client}; 170 | my $d = $client->search_discuss($msg->{did}); 171 | return defined $d?$d->{name}:undef; 172 | }; 173 | *Webqq::Message::DiscussMessage::Send::from_qq = sub{ 174 | my $msg = shift; 175 | my $client = $msg->{client}; 176 | return $client->{qq_param}{qq}; 177 | }; 178 | *Webqq::Message::DiscussMessage::Send::from_nick = sub{ 179 | return "我"; 180 | }; 181 | 182 | *Webqq::Message::GroupMessage::Recv::group_name = sub{ 183 | my $msg = shift; 184 | my $client = $msg->{client}; 185 | my $g = $client->search_group($msg->{group_code}); 186 | return defined $g?$g->{name}:undef ; 187 | }; 188 | *Webqq::Message::GroupMessage::Recv::from_gname = sub{ 189 | my $msg = shift; 190 | my $client = $msg->{client}; 191 | my $g = $client->search_group($msg->{group_code}); 192 | return defined $g?$g->{name}:undef ; 193 | }; 194 | *Webqq::Message::GroupMessage::Recv::from_qq = sub{ 195 | my $msg = shift; 196 | my $client = $msg->{client}; 197 | #my $m = $client->search_member_in_group($msg->{group_code},$msg->{send_uin}); 198 | #return $m->{qq} if(defined $m and defined $m->{qq}); 199 | return $client->get_qq_from_uin($msg->{send_uin}); 200 | }; 201 | *Webqq::Message::GroupMessage::Recv::from_nick = sub{ 202 | my $msg = shift; 203 | my $client = $msg->{client}; 204 | my $m = $client->search_member_in_group($msg->{group_code},$msg->{send_uin}); 205 | return defined $m?$m->{nick}:undef; 206 | }; 207 | *Webqq::Message::GroupMessage::Recv::from_card = sub{ 208 | my $msg = shift; 209 | my $client = $msg->{client}; 210 | my $m = $client->search_member_in_group($msg->{group_code},$msg->{send_uin}); 211 | return defined $m?$m->{card}:undef; 212 | }; 213 | *Webqq::Message::GroupMessage::Recv::from_city = sub{ 214 | my $msg = shift; 215 | my $client = $msg->{client}; 216 | my $m = $client->search_member_in_group($msg->{group_code},$msg->{send_uin}); 217 | return defined $m?$m->{city}:undef; 218 | }; 219 | 220 | *Webqq::Message::GroupMessage::Send::group_name = sub{ 221 | my $msg = shift; 222 | my $client = $msg->{client}; 223 | my $g = $client->search_group($msg->{group_code}); 224 | return defined $g?$g->{name}:undef; 225 | }; 226 | *Webqq::Message::GroupMessage::Send::to_gname = sub{ 227 | my $msg = shift; 228 | my $client = $msg->{client}; 229 | my $g = $client->search_group($msg->{group_code}); 230 | return defined $g?$g->{name}:undef; 231 | }; 232 | *Webqq::Message::GroupMessage::Send::from_qq = sub{ 233 | my $msg = shift; 234 | my $client = $msg->{client}; 235 | return $client->{qq_param}{qq}; 236 | }; 237 | *Webqq::Message::GroupMessage::Send::from_nick = sub{ 238 | return "我"; 239 | }; 240 | 241 | 242 | *Webqq::Message::SessMessage::Recv::from_nick = sub{ 243 | my $msg = shift; 244 | my $client = $msg->{client}; 245 | if($msg->{via} eq 'group'){ 246 | my $m = $client->search_member_in_group($msg->{group_code},$msg->{from_uin}); 247 | return defined $m?$m->{nick}:undef; 248 | } 249 | elsif($msg->{via} eq 'discuss'){ 250 | my $m = $client->search_member_in_discuss($msg->{did},$msg->{from_uin}); 251 | return defined $m?$m->{nick}:undef; 252 | } 253 | else{return undef} 254 | }; 255 | *Webqq::Message::SessMessage::Recv::from_qq = sub { 256 | my $msg = shift; 257 | my $client = $msg->{client}; 258 | return $msg->{ruin}; 259 | }; 260 | *Webqq::Message::SessMessage::Recv::to_nick = sub{ 261 | return "我"; 262 | }; 263 | *Webqq::Message::SessMessage::Recv::to_qq = sub { 264 | my $msg = shift; 265 | my $client = $msg->{client}; 266 | return $client->{qq_param}{qq}; 267 | }; 268 | 269 | *Webqq::Message::SessMessage::Recv::via_type = sub { 270 | my $msg = shift; 271 | my $client = $msg->{client}; 272 | return $msg->{via} eq 'group' ? "群" 273 | : $msg->{via} eq 'discuss' ? "讨论组" 274 | : undef 275 | ; 276 | }; 277 | *Webqq::Message::SessMessage::Recv::via_name = sub { 278 | my $msg = shift; 279 | my $client = $msg->{client}; 280 | if($msg->{via} eq 'group'){ 281 | my $g = $client->search_group($msg->{group_code}); 282 | return defined $g?$g->{name}:undef; 283 | } 284 | elsif($msg->{via} eq 'discuss'){ 285 | my $d = $client->search_discuss($msg->{did}); 286 | return defined $d?$d->{name}:undef; 287 | } 288 | else{return } 289 | }; 290 | 291 | 292 | *Webqq::Message::SessMessage::Send::from_nick = sub{ 293 | return "我"; 294 | }; 295 | *Webqq::Message::SessMessage::Send::from_qq = sub { 296 | my $msg = shift; 297 | my $client = $msg->{client}; 298 | return $client->{qq_param}{qq}; 299 | }; 300 | *Webqq::Message::SessMessage::Send::to_nick = sub{ 301 | my $msg = shift; 302 | my $client = $msg->{client}; 303 | if($msg->{via} eq 'group'){ 304 | my $m = $client->search_member_in_group($msg->{group_code},$msg->{to_uin}); 305 | return defined $m?$m->{nick}:undef; 306 | } 307 | elsif($msg->{via} eq 'discuss'){ 308 | my $m = $client->search_member_in_discuss($msg->{did},$msg->{to_uin}); 309 | return defined $m?$m->{nick}:undef; 310 | } 311 | else{return } 312 | }; 313 | *Webqq::Message::SessMessage::Send::to_qq = sub{ 314 | my $msg = shift; 315 | my $client = $msg->{client}; 316 | return $client->get_qq_from_uin($msg->{to_uin}); 317 | }; 318 | *Webqq::Message::SessMessage::Send::via_name = sub{ 319 | my $msg = shift; 320 | my $client = $msg->{client}; 321 | if($msg->{via} eq 'group'){ 322 | my $g = $client->search_group($msg->{group_code}); 323 | return defined $g?$g->{name}:undef; 324 | } 325 | elsif($msg->{via} eq 'discuss'){ 326 | my $d = $client->search_discuss($msg->{did}); 327 | return defined $d?$d->{name}:undef; 328 | } 329 | else{return} 330 | }; 331 | 332 | *Webqq::Message::SessMessage::Send::via_type = sub { 333 | my $msg = shift; 334 | my $client = $msg->{client}; 335 | return $msg->{via} eq 'group' ? "群" 336 | : $msg->{via} eq 'discuss' ? "讨论组" 337 | : undef 338 | ; 339 | }; 340 | *Webqq::Message::Message::Recv::from_nick = sub{ 341 | my $msg = shift; 342 | my $client = $msg->{client}; 343 | my $f = $client->search_friend($msg->{from_uin}); 344 | return defined $f?$f->{nick}:undef; 345 | }; 346 | *Webqq::Message::Message::Recv::from_qq = sub{ 347 | my $msg = shift; 348 | my $client = $msg->{client}; 349 | #my $f = $client->search_friend($msg->{from_uin}); 350 | #return $f->{qq} if(defined $f and defined $f->{qq}); 351 | return $client->get_qq_from_uin($msg->{from_uin}); 352 | }; 353 | *Webqq::Message::Message::Recv::from_markname = sub{ 354 | my $msg = shift; 355 | my $client = $msg->{client}; 356 | my $f = $client->search_friend($msg->{from_uin}); 357 | return defined $f?$f->{markname}:undef; 358 | }; 359 | *Webqq::Message::Message::Recv::from_categories = sub { 360 | my $msg = shift; 361 | my $client = $msg->{client}; 362 | my $f = $client->search_friend($msg->{from_uin}); 363 | return defined $f?$f->{categories}:undef; 364 | }; 365 | 366 | *Webqq::Message::Message::Recv::from_city = sub { 367 | my $msg = shift; 368 | my $client = $msg->{client}; 369 | my $f = $client->search_friend($msg->{from_uin}); 370 | return defined $f?$f->{city}:undef; 371 | }; 372 | 373 | *Webqq::Message::Message::Recv::to_nick = sub{ 374 | return "我"; 375 | }; 376 | *Webqq::Message::Message::Recv::to_qq = sub { 377 | my $msg = shift; 378 | my $client = $msg->{client}; 379 | return $client->{qq_param}{qq}; 380 | }; 381 | 382 | 383 | *Webqq::Message::Message::Send::from_nick = sub{ 384 | return "我"; 385 | }; 386 | *Webqq::Message::Message::Send::from_qq = sub{ 387 | my $msg = shift; 388 | my $client = $msg->{client}; 389 | return $client->{qq_param}{qq}; 390 | }; 391 | *Webqq::Message::Message::Send::to_nick = sub{ 392 | my $msg = shift; 393 | my $client = $msg->{client}; 394 | my $f = $client->search_friend($msg->{to_uin}); 395 | return defined $f?$f->{nick}:undef; 396 | }; 397 | *Webqq::Message::Message::Send::to_qq = sub{ 398 | my $msg = shift; 399 | my $client = $msg->{client}; 400 | return $client->get_qq_from_uin($msg->{to_uin}); 401 | }; 402 | *Webqq::Message::Message::Send::to_markname = sub{ 403 | my $msg = shift; 404 | my $client = $msg->{client}; 405 | my $f = $client->search_friend($msg->{to_uin}); 406 | return defined $f?$f->{markname}:undef; 407 | }; 408 | *Webqq::Message::Message::Send::to_categories = sub{ 409 | my $msg = shift; 410 | my $client = $msg->{client}; 411 | my $f = $client->search_friend($msg->{to_uin}); 412 | return defined $f?$f->{categories}:undef; 413 | }; 414 | 415 | } 416 | 417 | sub _mk_ro_accessors { 418 | my $client = shift; 419 | my $msg =shift; 420 | my $msg_pkg = shift; 421 | no strict 'refs'; 422 | for my $field (keys %$msg){ 423 | *{"Webqq::Message::${msg_pkg}::$field"} = sub{ 424 | my $self = shift; 425 | my $pkg = ref $self; 426 | die "the value of \"$field\" in $pkg is read-only\n" if @_!=0; 427 | return $self->{$field}; 428 | }; 429 | } 430 | 431 | $msg = bless $msg,"Webqq::Message::$msg_pkg"; 432 | return $msg; 433 | } 434 | 435 | sub parse_send_status_msg{ 436 | my $client = shift; 437 | my ($json_txt) = @_; 438 | my $json = undef; 439 | eval{$json = JSON->new->utf8->decode($json_txt)}; 440 | console "解析消息失败: $@ 对应的消息内容为: $json_txt\n" if $@ and $client->{debug}; 441 | if(ref $json eq 'HASH' and $json->{retcode}==0){ 442 | return {is_success=>1,status=>"发送成功"}; 443 | } 444 | else{ 445 | return {is_success=>0,status=>"发送失败"}; 446 | } 447 | } 448 | #消息的后期处理 449 | sub msg_put{ 450 | my $client = shift; 451 | my $msg = shift; 452 | $msg->{raw_content} = []; 453 | my $msg_content; 454 | shift @{ $msg->{content} }; 455 | for my $c (@{ $msg->{content} }){ 456 | if(ref $c eq 'ARRAY'){ 457 | if($c->[0] eq 'cface'){ 458 | push @{$msg->{raw_content}},{ 459 | type => 'cface', 460 | content => '[图片]', 461 | name => $c->[1]{name}, 462 | file_id => $c->[1]{file_id}, 463 | key => $c->[1]{key}, 464 | server => $c->[1]{server}, 465 | }; 466 | $c="[图片]"; 467 | } 468 | elsif($c->[0] eq 'offpic'){ 469 | push @{$msg->{raw_content}},{ 470 | type => 'offpic', 471 | content => '[图片]', 472 | file_path => $c->[1]{file_path}, 473 | }; 474 | $c="[图片]"; 475 | } 476 | elsif($c->[0] eq 'face'){ 477 | push @{$msg->{raw_content}},{ 478 | type => 'face', 479 | content => face_to_txt($c), 480 | id => $c->[1], 481 | }; 482 | $c=face_to_txt($c); 483 | } 484 | else{ 485 | push @{$msg->{raw_content}},{ 486 | type => 'unknown', 487 | content => '[未识别内容]', 488 | }; 489 | $c = "[未识别内容]"; 490 | } 491 | } 492 | elsif($c eq " "){ 493 | next; 494 | } 495 | else{ 496 | $c=encode("utf8",$c); 497 | $c=~s/ $//; 498 | $c=~s/\r|\n/\n/g; 499 | #{"retcode":0,"result":[{"poll_type":"group_message","value":{"msg_id":538,"from_uin":2859929324,"to_uin":3072574066,"msg_id2":545490,"msg_type":43,"reply_ip":182424361,"group_code":2904892801,"send_uin":1951767953,"seq":3024,"time":1418955773,"info_seq":390179723,"content":[["font",{"size":12,"color":"000000","style":[0,0,0],"name":"\u5FAE\u8F6F\u96C5\u9ED1"}],"[\u50BB\u7B11]\u0001 "]}}]} 500 | #if($c=~/\[[^\[\]]+?\]\x{01}/) 501 | push @{$msg->{raw_content}},{ 502 | type => 'txt', 503 | content => $c, 504 | }; 505 | } 506 | $msg_content .= $c; 507 | } 508 | $msg->{content} = $msg_content; 509 | $msg->{client} = $client; 510 | #将整个hash从unicode转为UTF8编码 511 | #$msg->{$_} = encode("utf8",$msg->{$_} ) for grep {$_ ne 'raw_content'} keys %$msg; 512 | #$msg->{content}=~s/\r|\n/\n/g; 513 | if($msg->{content}=~/\(\d+\) 被管理员禁言\d+(分钟|小时|天)$/ or $msg->{content}=~/\(\d+\) 被管理员解除禁言$/){ 514 | $msg->{type} = "sys_g_msg"; 515 | return; 516 | } 517 | my $msg_pkg = "\u$msg->{type}::Recv"; $msg_pkg=~s/_(.)/\u$1/g; 518 | $msg = $client->_mk_ro_accessors($msg,$msg_pkg) ; 519 | $client->{receive_message_queue}->put($msg); 520 | } 521 | 522 | sub parse_receive_msg{ 523 | my $client = shift; 524 | return if $client->{is_stop} ; 525 | my ($json_txt) = @_; 526 | my $json = undef; 527 | eval{$json = JSON->new->utf8->decode($json_txt)}; 528 | console "解析消息失败: $@ 对应的消息内容为: $json_txt\n" if $@ and $client->{debug}; 529 | if($json){ 530 | #一个普通的消息 531 | if($json->{retcode}==0){ 532 | $client->{poll_failure_count} = 0; 533 | for my $m (@{ $json->{result} }){ 534 | #收到群临时消息 535 | if($m->{poll_type} eq 'sess_message'){ 536 | my $msg = { 537 | type => 'sess_message', 538 | msg_id => $m->{value}{msg_id}, 539 | from_uin => $m->{value}{from_uin}, 540 | to_uin => $m->{value}{to_uin}, 541 | msg_time => $m->{value}{'time'}, 542 | content => $m->{value}{content}, 543 | service_type=> $m->{value}{service_type}, 544 | ruin => $m->{value}{ruin}, 545 | msg_class => "recv", 546 | ttl => 5, 547 | allow_plugin => 1, 548 | }; 549 | #service_type =0 表示群临时消息，1 表示讨论组临时消息 550 | if($m->{value}{service_type} == 0){ 551 | $msg->{gid} = $m->{value}{id}; 552 | $msg->{group_code} = $client->get_group_code_from_gid($m->{value}{id}), 553 | $msg->{via} = 'group'; 554 | } 555 | elsif($m->{value}{service_type} == 1){ 556 | $msg->{did} = $m->{value}{id}; 557 | $msg->{via} = 'discuss'; 558 | } 559 | else{return} 560 | $client->msg_put($msg); 561 | } 562 | #收到的消息是普通消息 563 | elsif($m->{poll_type} eq 'message'){ 564 | my $msg = { 565 | type => 'message', 566 | msg_id => $m->{value}{msg_id}, 567 | from_uin => $m->{value}{from_uin}, 568 | to_uin => $m->{value}{to_uin}, 569 | msg_time => $m->{value}{'time'}, 570 | content => $m->{value}{content}, 571 | msg_class => "recv", 572 | ttl => 5, 573 | allow_plugin => 1, 574 | }; 575 | $client->msg_put($msg); 576 | } 577 | #收到的消息是群消息 578 | elsif($m->{poll_type} eq 'group_message'){ 579 | my $msg = { 580 | type => 'group_message', 581 | msg_id => $m->{value}{msg_id}, 582 | from_uin => $m->{value}{from_uin}, 583 | to_uin => $m->{value}{to_uin}, 584 | msg_time => $m->{value}{'time'}, 585 | content => $m->{value}{content}, 586 | send_uin => $m->{value}{send_uin}, 587 | group_code => $m->{value}{group_code}, 588 | msg_class => "recv", 589 | ttl => 5, 590 | allow_plugin => 1, 591 | }; 592 | $client->msg_put($msg); 593 | } 594 | #收到讨论组消息 595 | elsif($m->{poll_type} eq 'discu_message'){ 596 | my $msg = { 597 | type => 'discuss_message', 598 | did => $m->{value}{did}, 599 | from_uin => $m->{value}{from_uin}, 600 | msg_id => $m->{value}{msg_id}, 601 | send_uin => $m->{value}{send_uin}, 602 | msg_time => $m->{value}{'time'}, 603 | to_uin => $m->{value}{'to_uin'}, 604 | content => $m->{value}{content}, 605 | msg_class => "recv", 606 | ttl => 5, 607 | allow_plugin => 1, 608 | }; 609 | $client->msg_put($msg); 610 | } 611 | elsif($m->{poll_type} eq 'buddies_status_change'){ 612 | my $msg = { 613 | type => 'buddies_status_change', 614 | uin => $m->{value}{uin}, 615 | state => $m->{value}{status}, 616 | client_type => code2client($m->{value}{client_type}), 617 | }; 618 | $client->msg_put($msg); 619 | } 620 | #收到系统消息 621 | elsif($m->{poll_type} eq 'sys_g_msg'){ 622 | #my $msg = { 623 | # type => 'sys_g_msg', 624 | # msg_id => $m->{value}{msg_id}, 625 | # from_uin => $m->{value}{from_uin}, 626 | # to_uin => $m->{value}{to_uin}, 627 | # 628 | #}; 629 | #$client->msg_put($msg); 630 | } 631 | #收到强制下线消息 632 | elsif($m->{poll_type} eq 'kick_message'){ 633 | if($m->{value}{show_reason} ==1){ 634 | my $reason = encode("utf8",$m->{value}{reason}); 635 | console "$reason\n"; 636 | $client->stop(); 637 | } 638 | else {console "您已被迫下线\n";$client->stop(); } 639 | } 640 | #还未识别和处理的消息 641 | else{ 642 | 643 | } 644 | } 645 | } 646 | #可以忽略的消息，暂时不做任何处理 647 | elsif($json->{retcode} == 102 or $json->{retcode} == 109 or $json->{retcode} == 110 ){ 648 | $client->{poll_failure_count} = 0; 649 | } 650 | #更新客户端ptwebqq值 651 | elsif($json->{retcode} == 116){ 652 | $client->{qq_param}{ptwebqq} = $json->{p}; 653 | $client->{cookie_jar}->set_cookie(0,"ptwebqq",$json->{p},"/","qq.com",); 654 | } 655 | #未重新登录 656 | elsif($json->{retcode} ==100){ 657 | console "因网络或其他原因与服务器失去联系，客户端需要重新登录...\n"; 658 | $client->relogin(); 659 | } 660 | #重新连接失败 661 | elsif($json->{retcode} ==120 or $json->{retcode} ==121 ){ 662 | console "因网络或其他原因与服务器失去联系，客户端需要重新连接...\n"; 663 | $client->_relink(); 664 | } 665 | #其他未知消息 666 | else{ 667 | $client->{poll_failure_count}++; 668 | console "获取消息失败，当前失败次数: $client->{poll_failure_count}\n"; 669 | if($client->{poll_failure_count} > $client->{poll_failure_count_max}){ 670 | console "接收消息失败次数超过最大值，尝试进行重新连接...\n"; 671 | $client->{poll_failure_count} = 0; 672 | $client->_relink(); 673 | } 674 | } 675 | } 676 | } 677 | 1; 678 | 679 | --------------------------------------------------------------------------------