File Coverage

blib/lib/Mojo/Weixin/Request.pm
Criterion Covered Total %
statement 6 158 3.8
branch 0 100 0.0
condition 0 36 0.0
subroutine 2 14 14.2
pod 0 8 0.0
total 8 316 2.5


line stmt bran cond sub pod time code
1             package Mojo::Weixin::Request;
2 1     1   9 use Mojo::Util ();
  1         2  
  1         28  
3 1     1   6 use List::Util qw(first);
  1         1  
  1         2153  
4             sub gen_url{
5 0     0 0   my $self = shift;
6 0           my ($url,@query_string) = @_;
7 0           my @query_string_pairs;
8 0           while(@query_string){
9 0           my $key = shift(@query_string);
10 0           my $val = shift(@query_string);
11 0 0         $key = "" if not defined $key;
12 0 0         $val = "" if not defined $val;
13 0           push @query_string_pairs , $key . "=" . $val;
14             }
15 0           return $url . '?' . join("&",@query_string_pairs);
16             }
17              
18             sub gen_url2{
19 0     0 0   my $self = shift;
20 0           my ($url,@query_string) = @_;
21 0           my @query_string_pairs;
22 0           while(@query_string){
23 0           my $key = shift(@query_string);
24 0           my $val = shift(@query_string);
25 0 0         $key = "" if not defined $key;
26 0 0         $val = "" if not defined $val;
27 0           push @query_string_pairs , $key . "=" . Mojo::Util::url_escape($val);
28             }
29 0           return $url . '?' . join("&",@query_string_pairs);
30             }
31              
32             sub http_get{
33 0     0 0   my $self = shift;
34 0           return $self->_http_request("get",@_);
35             }
36             sub http_post{
37 0     0 0   my $self = shift;
38 0           return $self->_http_request("post",@_);
39             }
40             sub _ua_debug {
41 0     0     my ($self,$ua,$tx,$opt,$is_blocking) = @_;
42 0 0         return if not $opt->{ua_debug};
43 0 0         $self->print("-- " . ($is_blocking?"Blocking":"Non-blocking"). " request (@{[$tx->req->url->to_abs]})\n");
  0            
44              
45 0 0         if($opt->{ua_debug_req_body}){#是否打印请求body
46 0           my $req_content_type = eval {$tx->req->headers->content_type};
  0            
47 0 0 0       if(defined $req_content_type and $req_content_type =~ /^multipart\/form-data; boundary=(.+?)$/){#对于文件上传不打印body中的二进制
48 0           my $body = $tx->req->build_body;
49 0           my $boundary = "--".$1;
50 0           my $filename_pos = index($body,"filename=");
51 0 0         if($filename_pos != -1){
52 0           my $binary_start_pos = index($body,"\r\n\r\n",$filename_pos);
53 0 0         if($binary_start_pos!=-1){
54 0           my $binary_end_pos = index($body,$boundary,$binary_start_pos);
55 0 0         substr($body,$binary_start_pos,$binary_end_pos-$binary_start_pos+1,"\r\n\r\n[binary data not shown]\r\n") if $binary_end_pos != -1;
56             }
57             }
58 0           $self->print("-- Client >>> Server (@{[$tx->req->url->to_abs]})\n@{[$tx->req->build_start_line . $tx->req->build_headers]}\n$body\n");
  0            
  0            
59             }
60             else{#其他非文件上传的请求,打印完整的header和body
61 0           $self->print("-- Client >>> Server (@{[$tx->req->url->to_abs]})\n@{[$tx->req->to_string]}\n");
  0            
  0            
62             }
63            
64             }
65             else{
66 0           $self->print("-- Client >>> Server (@{[$tx->req->url->to_abs]})\n@{[$tx->req->build_start_line . $tx->req->build_headers]}\n[body data skipped]\n");
  0            
  0            
67             }
68              
69 0 0         if($opt->{ua_debug_res_body}){
70 0           my $res_content_type = eval {$tx->res->headers->content_type};
  0            
71 0 0 0       if(defined $res_content_type and $res_content_type =~m#^(image|video|auido)/|^application/octet-stream#){
72 0           $self->print("-- Server >>> Client (@{[$tx->req->url->to_abs]})\n@{[$tx->res->build_start_line . $tx->res->build_headers]}\n[binary data not shown]");
  0            
  0            
73             }
74             else{
75 0           $self->print("-- Server >>> Client (@{[$tx->req->url->to_abs]})\n@{[$tx->res->to_string]}\n");
  0            
  0            
76             }
77             }
78             else{
79 0           $self->print("-- Server >>> Client (@{[$tx->req->url->to_abs]})\n@{[$tx->res->build_start_line . $tx->res->build_headers]}\n[body data skipped]\n");
  0            
  0            
80             }
81             }
82             sub _http_request{
83 0     0     my $self = shift;
84 0           my $method = shift;
85 0           my %opt = (
86             json => 0,
87             blocking => 0,
88             ua_retry_times => $self->ua_retry_times,
89             #ua_connect_timeout => $self->ua_connect_timeout,
90             #ua_request_timeout => $self->ua_request_timeout,
91             #ua_inactivity_timeout => $self->ua_inactivity_timeout,
92             ua_debug => $self->ua_debug,
93             ua_debug_res_body => $self->ua_debug_res_body,
94             ua_debug_req_body => $self->ua_debug_req_body
95             );
96 0 0         if(ref $_[1] eq "HASH"){#with header or option
97 0 0         $opt{json} = delete $_[1]->{json} if defined $_[1]->{json};
98 0 0         $opt{blocking} = delete $_[1]->{blocking} if defined $_[1]->{blocking};
99 0 0         $opt{ua_retry_times} = delete $_[1]->{ua_retry_times} if defined $_[1]->{ua_retry_times};
100 0 0         $opt{ua_debug} = delete $_[1]->{ua_debug} if defined $_[1]->{ua_debug};
101 0 0         $opt{ua_debug_res_body} = delete $_[1]->{ua_debug_res_body} if defined $_[1]->{ua_debug_res_body};
102 0 0         $opt{ua_debug_req_body} = delete $_[1]->{ua_debug_req_body} if defined $_[1]->{ua_debug_req_body};
103 0 0         $opt{ua_connect_timeout} = delete $_[1]->{ua_connect_timeout} if defined $_[1]->{ua_connect_timeout};
104 0 0         $opt{ua_request_timeout} = delete $_[1]->{ua_request_timeout} if defined $_[1]->{ua_request_timeout};
105 0 0         $opt{ua_inactivity_timeout} = delete $_[1]->{ua_inactivity_timeout} if defined $_[1]->{ua_inactivity_timeout};
106             }
107 0 0 0       if(ref $_[-1] eq "CODE" and !$opt{blocking}){
108 0           $self->debug("issue request[$method] to [$_[0]]");
109 0           my $cb = pop;
110             return $self->ua->$method(@_,sub{
111 0     0     my($ua,$tx) = @_;
112 0 0         _ua_debug($self,$ua,$tx,\%opt,0) if $opt{ua_debug};
113 0           $self->save_cookie();
114 0 0 0       if(defined $tx and $tx->res->is_success){
    0          
115 0 0         my $r = $opt{json}?$self->from_json($tx->res->body):$tx->res->body;
116 0           $cb->($r,$ua,$tx);
117             }
118             elsif(defined $tx){
119 0   0       $self->warn($tx->req->url->to_abs . " 请求失败: " . ($tx->error->{code}||"-") . " " . $self->encode_utf8($tx->error->{message}));
120 0           $cb->(undef,$ua,$tx);
121             }
122 0           });
123             }
124             else{
125 0           my $tx;
126 0 0         my $cb = pop if ref $_[-1] eq "CODE";
127 0           for(my $i=0;$i<=$opt{ua_retry_times};$i++){
128              
129 0           $self->debug("issue request[$method] to [$_[0]]");
130             #fix bug Mojo::IOLoop already running Mojo/UserAgent.pm
131             #https://github.com/kraih/mojo/issues/1029
132 0 0         $self->ua->ioloop->stop if $self->ua->ioloop->is_running;
133              
134 0 0 0       if($opt{ua_connect_timeout} or $opt{ua_request_timeout} or $opt{ua_inactivity_timeout}){
      0        
135 0           my $connect_timeout = $self->ua->connect_timeout;
136 0           my $request_timeout = $self->ua->request_timeout;
137 0           my $inactivity_timeout = $self->ua->inactivity_timeout;
138 0 0         $self->ua->connect_timeout($opt{ua_connect_timeout}) if $opt{ua_connect_timeout};
139 0 0         $self->ua->request_timeout($opt{ua_request_timeout}) if $opt{ua_request_timeout};
140 0 0         $self->ua->inactivity_timeout($opt{ua_inactivity_timeout}) if $opt{ua_inactivity_timeout};
141 0           $tx = $self->ua->$method(@_);
142 0           $self->ua->connect_timeout($connect_timeout)
143             ->request_timeout($request_timeout)
144             ->inactivity_timeout($inactivity_timeout);
145             }
146             else{
147 0           $tx = $self->ua->$method(@_);
148             }
149 0 0         _ua_debug($self,$ua,$tx,\%opt,1) if $opt{ua_debug};
150 0           $self->save_cookie();
151 0 0 0       if(defined $tx and $tx->res->is_success){
    0          
152 0 0         my $r = $opt{json}?$self->from_json($tx->res->body):$tx->res->body;
153 0 0         $cb->($r,$ua,$tx) if defined $cb;
154 0 0         return wantarray?($r,$self->ua,$tx):$r;
155             }
156             elsif(defined $tx){
157 0   0       $self->warn($tx->req->url->to_abs . " 请求($i/$opt{ua_retry_times})失败: " . ($tx->error->{code} || "-") . " " . $self->encode_utf8($tx->error->{message}));
158 0           next;
159             }
160             }
161             #$self->warn($tx->req->url->to_abs . " 请求最终失败: " . ($tx->error->{code}||"-") . " " . $self->encode_utf8($tx->error->{message})) if defined $tx;
162 0 0         $cb->($r,$ua,$tx) if defined $cb;
163 0 0         return wantarray?(undef,$self->ua,$tx):undef;
164             }
165             }
166              
167             sub load_cookie{
168 0     0 0   my $self = shift;
169 0 0         return if not $self->keep_cookie;
170 0           my $cookie_jar;
171 0           my $cookie_path = $self->cookie_path;
172 0 0         return if not -f $cookie_path;
173 0           eval{require Storable;$cookie_jar = Storable::retrieve($cookie_path);};
  0            
  0            
174 0 0         if($@){
175 0           $self->warn("客户端加载cookie[ $cookie_path ]失败: $@");
176 0           return;
177             }
178             else{
179 0           $self->info("客户端加载cookie[ $cookie_path ]");
180 0           $self->ua->cookie_jar($cookie_jar);
181              
182             #更新账号主域名
183 0   0       my $domain = $self->search_cookie('wxuin','domain') // $self->search_cookie('wxsid','domain');
184 0 0 0       if ($domain and $domain ne $self->domain){
185 0           $self->domain( $domain );
186 0           $self->debug("账号域名更新为:$domain");
187             }
188             }
189              
190             }
191             sub save_cookie{
192 0     0 0   my $self = shift;
193 0 0         return if not $self->keep_cookie;
194 0           my $cookie_path = $self->cookie_path;
195 0           eval{require Storable;Storable::nstore($self->ua->cookie_jar,$cookie_path);};
  0            
  0            
196 0 0         $self->warn("客户端保存cookie[ $cookie_path ]失败: $@") if $@;
197             }
198              
199             sub search_cookie{
200 0     0 0   my $self = shift;
201 0           my $cookie = shift;
202 0   0       my $type = shift // 'value'; #默认查询cookie对应的值
203 0           my @cookies;
204 0           my @tmp = $self->ua->cookie_jar->all;
205 0 0 0       if(@tmp == 1 and ref $tmp[0] eq "ARRAY"){
206 0           @cookies = @{$tmp[0]};
  0            
207             }
208             else{
209 0           @cookies = @tmp;
210             }
211 0     0     my $c = first { $_->name eq $cookie} @cookies;
  0            
212 0 0         return defined $c?$c->$type:undef;
213             }
214             sub clear_cookie{
215 0     0 0   my $self = shift;
216 0           $self->info("客户端清除cookie[ " . $self->cookie_path . "]");
217 0           $self->ua->cookie_jar->empty;
218 0           $self->save_cookie();
219             }
220             1;