1package Mojo::Weixin::Controller;
2use strict;
3use Config;
4use File::Spec;
5use Mojo::Weixin::Base 'Mojo::EventEmitter';
6use Mojo::Weixin;
7use Mojo::Weixin::Server;
8use Mojo::Weixin::Log;
9use Mojo::UserAgent;
10use Mojo::IOLoop;
11use IO::Socket::IP;
12use Time::HiRes ();
13use Storable qw();
14use POSIX qw();
15use File::Spec ();
16use if $^O eq "MSWin32",'Win32::Process';
17use if $^O eq "MSWin32",'Win32';
18use base qw(Mojo::Weixin::Util Mojo::Weixin::Request);
19our $VERSION = $Mojo::Weixin::VERSION;
20
21has backend => sub{+{}};
22has ioloop  => sub {Mojo::IOLoop->singleton};
23has backend_start_port => 3000;
24has post_api => undef;
25has poll_api => undef;
26has poll_interval => 5;
27has auth     => undef;
28has server =>  sub { Mojo::Weixin::Server->new };
29has listen => sub { [{host=>"0.0.0.0",port=>2000},] };
30
31has http_debug          => sub{$ENV{MOJO_WEIXIN_CONTROLLER_HTTP_DEBUG} || 0 } ;
32has ua_debug            => sub{$_[0]->http_debug};
33has ua_debug_req_body   => sub{$_[0]->ua_debug};
34has ua_debug_res_body   => sub{$_[0]->ua_debug};
35has ua_debug_req_body   => sub{$_[0]->ua_debug};
36has ua_debug_res_body   => sub{$_[0]->ua_debug};
37has ua_retry_times          => 5;
38has ua_connect_timeout      => 10;
39has ua_request_timeout      => 120;
40has ua_inactivity_timeout   => 120;
41has ua  => sub {
42    Mojo::UserAgent->new(
43        connect_timeout=>$_[0]->ua_connect_timeout,
44        request_timeout=>$_[0]->ua_request_timeout,
45        inactivity_timeout=>$_[0]->ua_inactivity_timeout,
46    )
47};
48
49has tmpdir              => sub {File::Spec->tmpdir();};
50has keep_cookie         => 0;
51has cookie_path         => sub {File::Spec->catfile($_[0]->tmpdir,join('','mojo_weixin_controller_cookie','.dat'))};
52has pid_path            => sub {File::Spec->catfile($_[0]->tmpdir,join('','mojo_weixin_controller_process','.pid'))};
53has backend_path        => sub {File::Spec->catfile($_[0]->tmpdir,join('','mojo_weixin_controller_backend','.dat'))};
54has template_path        => sub {File::Spec->catfile($_[0]->tmpdir,join('','mojo_weixin_controller_template','.pl'))};
55has check_interval      => 5;
56
57has log_level           => 'info';     #debug|info|msg|warn|error|fatal
58has log_path            => undef;
59has log_encoding        => undef;      #utf8|gbk|...
60has log_head            => "[wxc][$$]";
61has log_console         => 1;
62has disable_color       => 0;
63has max_clients         => 100;
64
65has version             => sub{$Mojo::Weixin::Controller::VERSION};
66
67has log     => sub{
68    Mojo::Weixin::Log->new(
69        encoding    =>  $_[0]->log_encoding,
70        path        =>  $_[0]->log_path,
71        level       =>  $_[0]->log_level,
72        head        =>  $_[0]->log_head,
73        disable_color   => $_[0]->disable_color,
74        console_output  => $_[0]->log_console,
75    )
76};
77sub new {
78    my $class = shift;
79    my $self  = $class->SUPER::new(@_);
80    $self->info("当前正在使用 Mojo-Weixin-Controller v" . $self->version);
81    $self->ioloop->reactor->on(error=>sub{
82        my ($reactor, $err) = @_;
83        $self->error("reactor error: " . Carp::longmess($err));
84    });
85    $SIG{__WARN__} = sub{$self->warn(Carp::longmess @_);};
86    $self->on(error=>sub{
87        my ($self, $err) = @_;
88        $self->error(Carp::longmess($err));
89    });
90    if( $^O!~/^MSWin32/i and $Config{d_pseudofork}){
91        $self->fatal("非常抱歉, Mojo-Weixin-Controller不支持您当前使用的系统");
92        $self->stop();
93    }
94    $self->check_pid();
95    $self->load_backend();
96    $self->check_client();
97    $SIG{CHLD} =  'IGNORE';
98    $SIG{INT} = $SIG{KILL} = $SIG{TERM} = $SIG{HUP} = sub{
99        $self->info("捕获到停止信号[$_[0]]，准备停止...");
100        $self->info("正在停止Controller...");
101        $self->save_backend();
102        $self->clean_pid();
103        $self->stop();
104    };
105    eval{$0 = 'wxcontroller';} if $^O ne 'MSWin32';
106    if(defined $self->poll_api){
107        $self->on('_mojo_weixin_controller_poll_over' => sub{
108            $self->http_get($self->poll_api,sub{
109                $self->ioloop->timer($self->poll_interval || 5,sub {$self->emit('_mojo_weixin_controller_poll_over');});
110            });
111        });
112    }
113    $Mojo::Weixin::Controller::_CONTROLLER = $self;
114    $self;
115}
116sub stop{
117    my $self = shift;
118    $self->info("Controller停止运行");
119    CORE::exit();
120}
121
122sub save_backend{
123    my $self = shift;
124    my $backend_path = $self->backend_path;
125    eval{Storable::nstore($self->backend,$backend_path);};
126    $self->warn("Controller保存backend失败: $@") if $@;
127
128}
129sub load_backend {
130    my $self = shift;
131    my $backend_path = $self->backend_path;
132    return if not -f $backend_path;
133    eval{$self->backend(Storable::retrieve($backend_path))};
134    if($@){
135        $self->warn("Controller加载backend失败: $@");
136        return;
137    }
138    else{
139        $self->info("Controller加载backend[ $backend_path ]");
140    }
141}
142sub check_pid {
143    my $self = shift;
144    return if not $self->pid_path;
145    eval{
146        if(not -f $self->pid_path){
147            $self->spurt($$,$self->pid_path);
148        }
149        else{
150            my $pid = $self->slurp($self->pid_path);
151            if( $pid=~/^\d+$/ and kill(0, $pid) ){
152                $self->warn("检测到有其他运行中的Controller(pid:$pid), 请先将其关闭");
153                $self->stop();
154            }
155            else{
156                $self->spurt($$,$self->pid_path);
157            }
158        }
159    };
160    $self->warn("进程检测遇到异常: $@") if $@;
161
162}
163
164
165sub clean_pid {
166    my $self = shift;
167    return if not defined $self->pid_path;
168    return if not -f $self->pid_path;
169    $self->info("清除残留的Controller pid文件");
170    unlink $self->pid_path or $self->warn("删除pid文件[ " . $self->pid_path . " ]失败: $!");
171}
172
173sub kill_process {
174    my $self = shift;
175    my $ret = 0;
176    if(!$_[0] or $_[0]!~/^\d+$/){
177        $self->error("pid无效，无法终止进程");
178        return;
179    }
180    if($^O  eq "MSWin32"){
181    #    my $exitcode = 0;
182    #    Win32::Process::KillProcess($_[0],$exitcode);
183    #    return $exitcode;
184        $ret = kill POSIX::SIGINT,$_[0] ;
185    }
186    else{
187        $ret = kill POSIX::SIGTERM,$_[0] ;
188    }
189
190    #client进程退出没有那么快，马上检查的话，仍然是存在的，干脆先不检查了
191    #return !$self->check_process($_[0]);
192
193    return $ret;
194}
195sub check_process {
196    my $self = shift;
197    if(!$_[0] or $_[0]!~/^\d+$/){
198        $self->error("pid无效，无法检测进程");
199        return;
200    }
201    #if($^O  eq "MSWin32"){
202    #    my $p;
203    #    return Win32::Process::Open($p,$_[0],0);
204    #}
205    kill 0,$_[0];
206}
207sub start_client {
208    my $self = shift;
209    my $param = shift;
210    if(!$param->{client}){
211        return {code => 1, status=>'client not found',};
212    }
213    elsif($self->max_clients < keys %{$self->backend}){
214        return {code => 5, status=>'max clients exceed'};
215    }
216    elsif(exists $self->backend->{$param->{client}}){
217        if( $self->check_process($self->backend->{$param->{client}}{pid}) ){
218            my %client = %{ $self->backend->{$param->{client}} };
219            for(keys %client){ delete $client{$_} if substr($_,0,1) eq "_"};
220            return {code=>0, status=>'client already exists',%client};
221        }
222    }
223    my $backend_port = empty_port({host=>'127.0.0.1',port=>$self->backend_start_port,proto=>'tcp'});
224    return {code => 2, status=>'no available port',client=>$param->{client}} if not defined $backend_port;
225    my $post_api = $param->{post_api} || $self->post_api;
226    my $poll_api = $param->{poll_api};
227    if(defined $post_api){
228        my $url = Mojo::URL->new($post_api);
229        $url->query->merge(client=>$param->{client});
230        $post_api =  $url->to_string;
231    }
232    if(defined $poll_api){
233        my $url = Mojo::URL->new($poll_api);
234        $url->query->merge(client=>$param->{client});
235        $poll_api =  $url->to_string;
236    }
237    $param->{account} = $param->{client};
238
239    for my $env(keys %ENV){
240        delete $ENV{$env} if $env=~/^MOJO_WEIXIN_([A-Z_]+)$/;
241    }
242    for my $p (keys %$param){
243        my $env_key = "MOJO_WEIXIN_" . uc($p);
244        $ENV{$env_key} = $param->{$p};
245    }
246    $ENV{MOJO_WEIXIN_PLUGIN_OPENWX_PORT} = $backend_port;
247    $ENV{MOJO_WEIXIN_PLUGIN_OPENWX_POST_API} = $post_api;
248    $ENV{MOJO_WEIXIN_PLUGIN_OPENWX_POLL_API} = $poll_api;
249
250    $ENV{MOJO_WEIXIN_LOG_PATH} = $self->log_path;
251    $ENV{MOJO_WEIXIN_LOG_ENCODING} = $self->log_encoding;
252    $ENV{MOJO_WEIXIN_LOG_CONSOLE} = $self->log_console;
253    $ENV{MOJO_WEIXIN_DISABLE_COLOR} = $self->disable_color;
254    $ENV{MOJO_WEIXIN_HTTP_DEBUG} = $self->http_debug;
255    $ENV{MOJO_WEIXIN_LOG_LEVEL} = $self->log_level;
256    $ENV{MOJO_WEIXIN_CONTROLLER_PID} = $$;
257
258    $ENV{MOJO_WEIXIN_TMPDIR} = $self->tmpdir if not defined $ENV{MOJO_WEIXIN_TMPDIR};
259    $ENV{MOJO_WEIXIN_STATE_PATH} = File::Spec->catfile($ENV{MOJO_WEIXIN_TMPDIR},join('','mojo_weixin_state_',$ENV{MOJO_WEIXIN_ACCOUNT},'.json')) if not defined $ENV{MOJO_WEIXIN_STATE_PATH};
260    $ENV{MOJO_WEIXIN_QRCODE_PATH} = File::Spec->catfile($ENV{MOJO_WEIXIN_TMPDIR},join('','mojo_weixin_qrcode_',$ENV{MOJO_WEIXIN_ACCOUNT},'.jpg')) if not defined $ENV{MOJO_WEIXIN_QRCODE_PATH};
261    $ENV{MOJO_WEIXIN_PID_PATH} = File::Spec->catfile($ENV{MOJO_WEIXIN_TMPDIR},join('','mojo_weixin_pid_',$ENV{MOJO_WEIXIN_ACCOUNT},'.pid')) if not defined $ENV{MOJO_WEIXIN_PID_PATH};
262    local $ENV{PERL5LIB} = join( ($^O eq "MSWin32"?";":":"),@INC);
263    if(!-f $self->template_path or -z $self->template_path){
264        my $template =<<'MOJO_WEIXIN_CLIENT_TEMPLATE';
265#!/usr/bin/env perl
266use Mojo::Weixin;
267$|=1;
268my $client = Mojo::Weixin->new(log_head=>"[$ENV{MOJO_WEIXIN_ACCOUNT}][$$]");
269$0 = "wxclient(" . $client->account . ")" if $^O ne "MSWin32";
270$client->load(["ShowMsg","UploadQRcode"]);
271$client->load("Openwx",data=>{listen=>[{host=>"127.0.0.1",port=>$ENV{MOJO_WEIXIN_PLUGIN_OPENWX_PORT} }], post_api=>$ENV{MOJO_WEIXIN_PLUGIN_OPENWX_POST_API} || undef,post_event=>$ENV{MOJO_WEIXIN_PLUGIN_OPENWX_POST_EVENT} // 1,post_media_data=> $ENV{MOJO_WEIXIN_PLUGIN_OPENWX_POST_MEDIA_DATA} // 1, poll_api=>$ENV{MOJO_WEIXIN_PLUGIN_OPENWX_POLL_API} || undef, poll_interval => $ENV{MOJO_WEIXIN_PLUGIN_OPENWX_POLL_INTERVAL} },call_on_load=>1);
272$client->run();
273MOJO_WEIXIN_CLIENT_TEMPLATE
274        $self->spurt($template,$self->template_path);
275    }
276    $self->info("使用模版[" . $self->template_path .  "]创建客户端");
277    if( $^O eq 'MSWin32'){#Windows
278        my $process;
279        no strict;
280        my $p = $self->decode("gbk",$Config{perlpath});
281        if($p=~/\p{Han}|\s+/){
282            $self->warn("perl路径包含空格或中文可能导致客户端创建失败: [" . $self->encode("utf8",$p) . "]");
283        }
284        if(Win32::Process::Create($process,$Config{perlpath},'perl ' . $self->template_path,0,CREATE_NEW_PROCESS_GROUP,".") ){
285
286            my $pid;eval{$pid = $process->GetProcessID()};
287            if($pid!~/^\d+$/){
288                return {code=>4,status=>'client pid not ok' };
289            }
290            $self->backend->{$param->{client}} = $param;
291            $self->backend->{$param->{client}}{pid} = $pid;
292            $self->backend->{$param->{client}}{port} = $backend_port;
293            $self->backend->{$param->{client}}{_tmpdir} = $ENV{MOJO_WEIXIN_TMPDIR};
294            $self->backend->{$param->{client}}{_state_path} = $ENV{MOJO_WEIXIN_STATE_PATH};
295            $self->backend->{$param->{client}}{_pid_path} = $ENV{MOJO_WEIXIN_PID_PATH};
296            $self->backend->{$param->{client}}{_qrcode_path} = $ENV{MOJO_WEIXIN_QRCODE_PATH};
297            delete $self->backend->{$param->{client}}{log_head};
298            my %client = %{ $self->backend->{$param->{client}} };
299            for(keys %client){ delete $client{$_} if substr($_,0,1) eq "_"}
300            return {code=>0,status=>'success',%client };
301        }
302        else{
303            $self->error(
304                "创建客户端失败: " .
305                $self->encode("utf8",
306                    $self->decode("gbk",Win32::FormatMessage( Win32::GetLastError() ) || 'create client fail' )
307                )
308            );
309            #$self->error(Win32::FormatMessage( Win32::GetLastError() ) );
310            return {code=>3,status=>'failure',};
311        }
312    }
313    else{#Unix
314        my $pid = fork();
315        if($pid == 0) {#new process
316            $self->server->stop;
317            $self->ioloop->stop;
318            delete $self->server->{servers};
319            my $template_path = $self->template_path;
320            undef $self;
321            exec $Config{perlpath} || 'perl',$template_path;
322        }
323        else{
324            select undef,undef,undef,0.05;
325            if($pid!~/^\d+$/){
326                return {code=>4,status=>'client pid not ok' };
327            }
328            $self->backend->{$param->{client}} = $param;
329            $self->backend->{$param->{client}}{pid} = $pid;
330            $self->backend->{$param->{client}}{port} = $backend_port;
331            $self->backend->{$param->{client}}{_tmpdir} = $ENV{MOJO_WEIXIN_TMPDIR};
332            $self->backend->{$param->{client}}{_state_path} = $ENV{MOJO_WEIXIN_STATE_PATH};
333            $self->backend->{$param->{client}}{_pid_path} = $ENV{MOJO_WEIXIN_PID_PATH};
334            $self->backend->{$param->{client}}{_qrcode_path} = $ENV{MOJO_WEIXIN_QRCODE_PATH};
335            delete $self->backend->{$param->{client}}{log_head};
336            my %client = %{ $self->backend->{$param->{client}} };
337            for(keys %client){ delete $client{$_} if substr($_,0,1) eq "_"}
338            return {code=>0,status=>'success',%client };
339        }
340    }
341}
342
343sub stop_client {
344    my $self = shift;
345    my $param = shift;
346    if(!$param->{client}){
347        return {code => 1, status=>'client not found',};
348    }
349    elsif(!exists $self->backend->{$param->{client}}){
350        return {code => 1, status=>'client not exists',};
351    }
352    my $ret = $self->kill_process( $self->backend->{$param->{client}}{pid} );
353    if ($ret){
354        my $client = $self->backend->{$param->{client}};
355        delete $self->backend->{$param->{client}};
356        for(keys %$client){ delete $client->{$_} if substr($_,0,1) eq "_"}
357        return {code=>0,status=>'success',%$client };
358    }
359    return {code=>1,status=>'failure'};
360}
361
362sub check_client {
363    my $self = shift;
364    for my $client ( keys %{ $self->backend }  ){
365        my $pid = $self->backend->{$client}->{pid};
366        return if !$pid;
367        return if $pid !~ /^\d+$/;
368        my $ret = $self->check_process($pid);
369        if(not $ret){
370            $self->warn("检测到客户端 $client\[$pid\] 不存在，删除客户端信息");
371            delete $self->backend->{$client};
372        }
373    }
374}
375sub run {
376    my $self = shift;
377    my $server =  $self->server;
378    $server->app($server->build_app("Mojo::Weixin::Controller::App"));
379    $server->app->defaults(wxc=>$self);
380    $server->app->secrets("hello world");
381    $server->app->log($self->log);
382    $server->listen([ map { 'http://' . (defined $_->{host}?$_->{host}:"0.0.0.0") .":" . (defined $_->{port}?$_->{port}:2000)} @{ $self->listen } ]) ;
383    $server->start;
384    $self->ioloop->recurring($self->check_interval || 5,sub{
385        $self->check_client();
386        $self->save_backend();
387    });
388    $self->emit('_mojo_weixin_controller_poll_over');
389    $self->ioloop->start if not $self->ioloop->is_running;
390}
391
392package Mojo::Weixin::Controller::App::Controller;
393use Mojo::JSON ();
394use Mojo::Util ();
395use base qw(Mojolicious::Controller);
396sub render{
397    my $self = shift;
398    if($_[0] eq 'json'){
399        $self->res->headers->content_type('application/json');
400        $self->SUPER::render(data=>Mojo::JSON::to_json($_[1]),@_[2..$#_]);
401    }
402    else{$self->SUPER::render(@_)}
403}
404sub safe_render{
405    my $self = shift;
406    $self->render(@_) if (defined $self->tx and !$self->tx->is_finished);
407}
408sub param{
409    my $self = shift;
410    my $data = $self->SUPER::param(@_);
411    defined $data?Mojo::Util::encode("utf8",$data):undef;
412}
413sub params {
414    my $self = shift;
415    my $hash = $self->req->params->to_hash ;
416    $self->stash('wxc')->reform($hash);
417    return $hash;
418}
419package Mojo::Weixin::Controller::App;
420use Mojolicious::Lite;
421use Mojo::Transaction::HTTP;
422app->controller_class('Mojo::Weixin::Controller::App::Controller');
423under sub {
424    my $c = shift;
425    if(ref $c->stash('wxc')->auth eq "CODE"){
426        my $hash  = $c->params;
427        my $ret = 0;
428        eval{
429            $ret = $c->stash('wxc')->auth->($hash,$c);
430        };
431        $c->stash('wxc')->warn("插件[Mojo::Weixin::Controller]认证回调执行错误: $@") if $@;
432        $c->safe_render(text=>"auth failure",status=>403) if not $ret;
433        return $ret;
434    }
435    else{return 1}
436};
437get '/openwx/start_client' => sub{
438    my $c = shift;
439    my $hash   = $c->params;
440    my $result =  $c->stash('wxc')->start_client($hash);
441    $c->safe_render(json=>$result);
442};
443get '/openwx/stop_client' => sub{
444    my $c = shift;
445    my $hash   = $c->params;
446    my $result = $c->stash('wxc')->stop_client($hash);
447    $c->safe_render(json=>$result);
448};
449get '/openwx/get_qrcode' => sub{
450    my $c = shift;
451    my $client = $c->param("client");
452    if(!$client){
453        $c->safe_render(json=>{code => 1, status=>'client not found',});
454        return;
455    }
456    elsif(!exists $c->stash('wxc')->backend->{$client}){
457        $c->safe_render(json => {code => 1, status=>'client not exists',});
458        return;
459    }
460    eval{
461        my $qrcode_path = $c->stash('wxc')->backend->{$client}{_qrcode_path};
462        my $data = $c->stash('wxc')->slurp($qrcode_path);
463        $c->res->headers->cache_control('no-cache');
464        $c->res->headers->content_type('image/jpg');
465        $c->safe_render(data=>$data,);
466    };
467    if($@){
468        $c->stash('wxc')->warn("读取客户端二维码失败: $@");
469        $c->safe_render(text=>"",status=>404);
470    }
471};
472get '/openwx/check_client' => sub{
473    my $c = shift;
474    my $client = $c->param("client");
475    if(defined $client){
476        if(!exists $c->stash('wxc')->backend->{$client}){
477            $c->safe_render(json => {code => 1, status=>'client not exists',});
478            return;
479        }
480        else{
481            eval{
482                my $state_path = $c->stash('wxc')->backend->{$client}{_state_path};
483                my $json = $c->stash('wxc')->decode_json($c->stash('wxc')->slurp($state_path));
484                $json->{port} = $c->stash('wxc')->backend->{$client}{port};
485                $c->safe_render(json=>{code=>0,client=>[$json]});
486            };
487            if($@){
488                $c->stash('wxc')->warn("读取客户端state文件失败: $@");
489                #$c->safe_render(json=>{code=>0,client=>[ $c->stash('wxc')->backend->{$client}, ] });
490                $c->safe_render(json=>{code => 1,status=>"client state file read error"});
491            }
492        }
493    }
494    else{
495        eval{
496            my @client;
497            for my $client ( values %{ $c->stash('wxc')->backend }){
498                my $state_path = $client->{_state_path};
499                my $json = $c->stash('wxc')->from_json($c->stash('wxc')->slurp($state_path));
500                $json->{port} = $client->{port};
501                push @client,$json;
502            }
503            $c->safe_render(json=>{code=>0,client=>\@client});
504        };
505        if($@){
506            $c->stash('wxc')->warn("读取客户端state文件失败: $@");
507            #$c->safe_render(json=>{code=>0,client=>[ values %{ $c->stash('wxc')->backend } ]});
508            $c->safe_render(json=>{code => 1,status=>"client state file read error"});
509        }
510    }
511};
512any '/openwx/*whatever'  => sub{
513    my $c = shift;
514    my $client = $c->param("client");
515    if(!$client){
516        $c->safe_render(json=>{code => 1, status=>'client not found',});
517        return;
518    }
519    elsif(!exists $c->stash('wxc')->backend->{$client}){
520        $c->safe_render(json => {code => 1, status=>'client not exists',});
521        return;
522    }
523    $c->inactivity_timeout(120);
524    $c->render_later;
525    my $tx = Mojo::Transaction::HTTP->new(req=>$c->req->clone);
526    $tx->req->url->host("127.0.0.1");
527    $tx->req->url->port($c->stash('wxc')->backend->{$client}->{port});
528    $tx->req->url->scheme('http');
529    $tx->req->headers->header('Host',$tx->req->url->host_port);
530    return if $c->stash('mojo.finished');
531    $c->stash('wxc')->ua->start($tx,sub{
532        my ($ua,$tx) = @_;
533        $c->tx->res($tx->res);
534        $c->rendered;
535    });
536};
537any '/*whatever'  => sub{whatever=>'',$_[0]->safe_render(json=>{code=>-1,status=>"api not found"},status=>403)};
538package Mojo::Weixin::Controller;
539
540sub can_bind {
541    my ($host, $port, $proto) = @_;
542    # The following must be split across two statements, due to
543    # https://rt.perl.org/Public/Bug/Display.html?id=124248
544    my $s = _listen_socket($host, $port, $proto);
545    return defined $s;
546}
547
548sub _listen_socket {
549    my ($host, $port, $proto) = @_;
550    $port  ||= 0;
551    $proto ||= 'tcp';
552    IO::Socket::IP->new(
553        (($proto eq 'udp') ? () : (Listen => 5)),
554        LocalAddr => $host,
555        LocalPort => $port,
556        Proto     => $proto,
557        V6Only    => 1,
558        (($^O eq 'MSWin32') ? () : (ReuseAddr => 1)),
559    );
560}
561
562sub listen_socket {
563    my ($host, $proto) = @{$_[0]}{qw(host proto)};
564    $host = '127.0.0.1' unless defined $host;
565    return _listen_socket($host, undef, $proto);
566}
567
568# get a empty port on 49152 .. 65535
569# http://www.iana.org/assignments/port-numbers
570sub empty_port {
571    my ($host, $port, $proto) = @_ && ref $_[0] eq 'HASH' ? ($_[0]->{host}, $_[0]->{port}, $_[0]->{proto}) : (undef, @_);
572    $host = '127.0.0.1'
573        unless defined $host;
574    if (defined $port) {
575        $port = 49152 unless $port =~ /^[0-9]+$/ && $port < 49152;
576    } else {
577        $port = 50000 + (int(rand()*1500) + abs($$)) % 1500;
578    }
579    $proto = $proto ? lc($proto) : 'tcp';
580
581    $port--;
582    while ( $port++ < 65000 ) {
583        # Remote checks don't work on UDP, and Local checks would be redundant here...
584        next if ($proto eq 'tcp' && check_port({ host => $host, port => $port }));
585        return $port if can_bind($host, $port, $proto);
586    }
587    return;
588}
589
590sub check_port {
591    my ($host, $port, $proto) = @_ && ref $_[0] eq 'HASH' ? ($_[0]->{host}, $_[0]->{port}, $_[0]->{proto}) : (undef, @_);
592    $host = '127.0.0.1'
593        unless defined $host;
594    $proto = $proto ? lc($proto) : 'tcp';
595
596    # for TCP, we do a remote port check
597    # for UDP, we do a local port check, like empty_port does
598    my $sock = ($proto eq 'tcp') ?
599        IO::Socket::IP->new(
600            Proto    => 'tcp',
601            PeerAddr => $host,
602            PeerPort => $port,
603            V6Only   => 1,
604        ) :
605        IO::Socket::IP->new(
606            Proto     => $proto,
607            LocalAddr => $host,
608            LocalPort => $port,
609            V6Only   => 1,
610            (($^O eq 'MSWin32') ? () : (ReuseAddr => 1)),
611        )
612    ;
613
614    if ($sock) {
615        close $sock;
616        return 1; # The port is used.
617    }
618    else {
619        return 0; # The port is not used.
620    }
621
622}
6231;
624