{
use
5.010;
our
$MAJOR
= 0.074;
our
$MINOR
= 0;
our
$DEV
= 1;
our
$VERSION
=
sprintf
(
'%1.3f%03d'
. (
$DEV
? ((
$DEV
< 0 ?
''
:
'_'
) .
'%03d'
) : (
''
)),
$MAJOR
,
$MINOR
,
abs
$DEV
);
sub
BUILD {1}
sub
timer {
shift
; AnyEvent->timer(
@_
) }
sub
run { AnyEvent->condvar->
recv
}
has
'peer_id'
=> (
isa
=>
'NBTypes::Client::PeerID'
,
is
=>
'ro'
,
lazy_build
=> 1,
builder
=>
'_build_peer_id'
,
required
=> 1
);
sub
_build_peer_id {
return
pack
(
'a20'
,
(
sprintf
(
'NB%03d%1s-%8s%5s'
,
$MAJOR
* 1000,
(
$DEV
> 0 ?
'U'
:
'S'
),
(
join
''
,
map
{
[
'A'
..
'Z'
,
'a'
..
'z'
, 0 .. 9,
qw[- . _ ~]
]
->[
rand
(66)]
} 1 .. 8
),
'KaiLi'
)
)
);
}
has
'torrents'
=> (
traits
=> [
'Array'
],
isa
=>
'ArrayRef[Net::BitTorrent::Torrent]'
,
is
=>
'ro'
,
reader
=>
'_torrents'
,
default
=>
sub
{ [] },
coerce
=> 1,
handles
=> {
add_torrent
=>
'push'
,
clear_torrents
=>
'clear'
,
count_torrents
=>
'count'
,
filter_torrents
=>
'grep'
,
find_torrent
=>
'first'
,
has_torrents
=>
'count'
,
info_hashes
=> [
'map'
,
sub
{
$_
->info_hash }],
map_torrents
=>
'map'
,
no_torrents
=>
'is_empty'
,
shuffle_torrents
=>
'shuffle'
,
sort_torrents
=>
'sort'
,
torrent
=>
'get'
,
}
);
around
'add_torrent'
=>
sub
{
my
(
$code
,
$self
) = (
shift
,
shift
);
my
$torrent
;
if
(blessed
$_
[0]) {
$torrent
=
$_
[0]; }
else
{
$torrent
= Net::BitTorrent::Torrent->new(
@_
);
}
return
blessed
$torrent
&&
$code
->(
$self
,
$torrent
)
&&
$torrent
->client(
$self
);
};
my
$infohash_constraint
;
around
'torrent'
=>
sub
{
my
(
$code
,
$self
,
$index
) =
@_
;
my
$torrent
;
{
$infohash_constraint
//=
Moose::Util::TypeConstraints::find_type_constraint(
'NBTypes::Torrent::Infohash'
);
my
$infohash
=
$infohash_constraint
->coerce(
$index
);
$torrent
=
$self
->find_torrent(
sub
{
$_
->info_hash->Lexicompare(
$infohash
) == 0;
}
);
}
$torrent
=
$code
->(
$self
,
$index
)
if
!
defined
$torrent
&&
$index
=~ m[^\d$];
return
$torrent
;
};
has
'dht'
=> (
is
=>
'ro'
,
isa
=>
'Net::BitTorrent::DHT'
,
lazy_build
=> 1
);
sub
_build_dht {
Net::BitTorrent::DHT->new(
client
=>
shift
);
}
has
'port'
=> (
is
=>
'ro'
,
isa
=>
'Int'
,
default
=> 0,
writer
=>
'_set_port'
,
);
{
my
%_sock_types
= (
4
=>
'0.0.0.0'
,
6
=>
'::'
);
for
my
$prot
(
qw[tcp udp]
) {
for
my
$ipv
(
keys
%_sock_types
) {
has
$prot
.
$ipv
=> (
is
=>
'ro'
,
init_arg
=>
undef
,
isa
=>
'Object'
,
lazy_build
=> 1,
writer
=>
'_set_'
.
$prot
.
$ipv
,
predicate
=>
'_has_'
.
$prot
.
$ipv
);
has
$prot
.
$ipv
.
'_sock'
=> (
is
=>
'ro'
,
init_arg
=>
undef
,
isa
=>
'GlobRef'
,
lazy_build
=> 1,
weak_ref
=> 1,
writer
=>
'_set_'
.
$prot
.
$ipv
.
'_sock'
,
predicate
=>
'_has_'
.
$prot
.
$ipv
.
'_sock'
);
has
$prot
.
$ipv
.
'_host'
=> (
is
=>
'ro'
,
isa
=>
'Str'
,
default
=>
$_sock_types
{
$ipv
},
writer
=>
'_set_'
.
$prot
.
$ipv
.
'_host'
,
predicate
=>
'_has_'
.
$prot
.
$ipv
.
'_host'
);
}
}
}
after
'BUILD'
=>
sub
{
$_
[0]->
$_
()
for
qw[udp6 tcp6 udp4 tcp4]
};
sub
_build_tcp6 {
my
(
$self
) =
@_
;
return
Net::BitTorrent::Network::Utility::server(
$self
->tcp6_host,
$self
->port,
sub
{
$self
->_on_tcp6_in(
@_
); },
sub
{
my
(
$sock
,
$host
,
$port
) =
@_
;
$self
->_set_tcp6_sock(
$sock
);
$self
->_set_tcp6_host(
$host
);
$self
->_set_port(
$port
);
},
'tcp'
);
}
sub
_build_tcp4 {
my
(
$self
) =
@_
;
return
Net::BitTorrent::Network::Utility::server(
$self
->tcp4_host,
$self
->port,
sub
{
$self
->_on_tcp4_in(
@_
); },
sub
{
my
(
$sock
,
$host
,
$port
) =
@_
;
if
(
$self
->port !=
$port
) { ...; }
$self
->_set_tcp4_sock(
$sock
);
$self
->_set_tcp4_host(
$host
);
$self
->_set_port(
$port
);
},
'tcp'
);
}
sub
_build_udp6 {
my
(
$self
) =
@_
;
return
Net::BitTorrent::Network::Utility::server(
$self
->udp6_host,
$self
->port,
sub
{
$self
->_on_udp6_in(
@_
); },
sub
{
my
(
$sock
,
$host
,
$port
) =
@_
;
$self
->_set_udp6_sock(
$sock
);
$self
->_set_udp6_host(
$host
);
$self
->_set_port(
$port
);
},
'udp'
);
}
sub
_build_udp4 {
my
(
$self
) =
@_
;
return
Net::BitTorrent::Network::Utility::server(
$self
->udp4_host,
$self
->port,
sub
{
$self
->_on_udp4_in(
@_
); },
sub
{
my
(
$sock
,
$host
,
$port
) =
@_
;
if
(
$self
->port !=
$port
) { ...; }
$self
->_set_udp4_sock(
$sock
);
$self
->_set_udp4_host(
$host
);
$self
->_set_port(
$port
);
},
'udp'
);
}
sub
_on_tcp4_in {
my
(
$self
,
$peer
,
$paddr
,
$host
,
$port
) =
@_
;
$self
->add_peer(
Net::BitTorrent::Peer->new(
fh
=>
$peer
,
client
=>
$self
));
}
sub
_on_tcp6_in {
my
(
$self
,
$peer
,
$paddr
,
$host
,
$port
) =
@_
;
}
sub
_on_udp4_in {
my
$self
=
shift
;
my
(
$udp
,
$sock
,
$paddr
,
$host
,
$port
,
$data
,
$flags
) =
@_
;
$self
->dht->_on_udp4_in(
@_
);
}
sub
_on_upd6_in {
my
$self
=
shift
;
my
(
$udp
,
$sock
,
$paddr
,
$host
,
$port
,
$data
,
$flags
) =
@_
;
$self
->dht->_on_udp6_in(
@_
);
}
has
'_peers'
=> (
is
=>
'HashRef[Net::BitTorrent::Peer]'
,
is
=>
'ro'
,
traits
=> [
'Hash'
],
handles
=> {
peer
=>
'get'
,
add_peer
=>
'set'
,
del_peer
=>
'delete'
,
peer_ids
=>
'keys'
,
has_peer
=>
'defined'
,
peers
=>
'values'
,
clear_peers
=>
'clear'
,
count_peers
=>
'count'
,
no_peers
=>
'is_empty'
},
default
=>
sub
{ {} }
);
around
[
qw[peer add_peer del_peer has_peer]
] =>
sub
{
my
(
$code
,
$self
,
$arg
) =
@_
;
blessed
$arg
?
$code
->(
$self
,
$arg
->_id,
$arg
) :
$code
->(
$self
,
$arg
);
};
if
(0) {
sub
_build_callback_no_op {
sub
{1}
}
has
"on_$_"
=> (
isa
=>
'CodeRef'
,
is
=>
'rw'
,
traits
=> [
'Code'
],
handles
=> {
"trigger_$_"
=>
'execute_method'
},
lazy_build
=> 1,
builder
=>
'_build_callback_no_op'
,
weak_ref
=> 1
)
for
qw[
peer_construction peer_destruction
]
;
}
{
for
my
$type
(
qw[peer_construction peer_destruction]
) {
has
"_${type}_callbacks"
=> (
isa
=>
'ArrayRef[Ref]'
,
is
=>
'ro'
,
init_arg
=>
undef
,
traits
=> [
'Array'
],
handles
=> {
"add_${type}_callback"
=>
'push'
,
"${type}_callbacks"
=>
'elements'
,
"get_${type}_callback"
=>
'get'
,
"grep_${type}_callbacks"
=>
'grep'
,
"map_${type}_callbacks"
=>
'map'
,
"trigger_${type}_callback"
=>
[
'grep'
,
sub
{
$_
->[1]->()
if
$_
}]
},
default
=>
sub
{ [] }
);
around
"add_${type}_callback"
=>
sub
{
my
(
$c
,
$s
,
$cb
) =
@_
;
Scalar::Util::weaken
$s
;
$cb
= [
'*'
,
$cb
, [], ()];
$c
->(
$s
,
$cb
);
Scalar::Util::weaken
$s
->{
"_${type}_callbacks"
}->[-1];
return
$cb
;
};
}
}
{
my
@_plugins
;
sub
_register_plugin {
my
$s
=
shift
;
return
$s
->meta->apply(
@_
)
if
blessed
$s
;
my
%seen
= ();
return
@_plugins
=
grep
{ !
$seen
{
$_
}++ }
@_plugins
,
@_
;
}
after
'BUILD'
=>
sub
{
return
if
!
@_plugins
;
my
(
$s
,
$a
) =
@_
;
Moose::Util::apply_all_roles(
$s
,
@_plugins
,
{
rebless_params
=>
$a
});
};
}
}
1;