1#!/usr/bin/perl -w 2package Net::BitTorrent::Torrent::Tracker; 3{ 4 use strict; 5 use warnings; 6 use Carp qw[carp]; 7 use Scalar::Util qw[blessed weaken refaddr]; 8 use List::Util qw[shuffle]; 9 use lib q[./../../../]; 10 use Net::BitTorrent::Torrent::Tracker::HTTP; 11 use Net::BitTorrent::Torrent::Tracker::UDP; 12 use version qw[qv]; 13 our $VERSION_BASE = 50; our $UNSTABLE_RELEASE = 0; our $VERSION = sprintf(($UNSTABLE_RELEASE ? q[%.3f_%03d] : q[%.3f]), (version->new(($VERSION_BASE))->numify / 1000), $UNSTABLE_RELEASE); 14 my (@CONTENTS) = \my (%torrent, %urls); 15 my %REGISTRY; 16 17 sub new { 18 my ($class, $args) = @_; 19 my $self; 20 if ((!$args) || (ref($args) ne q[HASH])) { 21 carp 22 q[Net::BitTorrent::Torrent::Tracker->new({}) requires parameters to be passed as a hashref]; 23 return; 24 } 25 if ( (!$args->{q[URLs]}) 26 || (ref $args->{q[URLs]} ne q[ARRAY]) 27 || (!scalar(@{$args->{q[URLs]}}))) 28 { carp 29 q[Net::BitTorrent::Torrent::Tracker->new({}) requires a list of URLs]; 30 return; 31 } 32 if ( (!$args->{q[Torrent]}) 33 || (!blessed $args->{q[Torrent]}) 34 || (!$args->{q[Torrent]}->isa(q[Net::BitTorrent::Torrent]))) 35 { carp 36 q[Net::BitTorrent::Torrent::Tracker->new({}) requires a Torrent]; 37 return; 38 } 39 $self = bless(\$args->{q[URLs]}->[0], $class); 40 $torrent{refaddr $self} = $args->{q[Torrent]}; 41 weaken $torrent{refaddr $self}; 42 $urls{refaddr $self} = []; 43 for my $_url (@{$args->{q[URLs]}}) { 44 push @{$urls{refaddr $self}}, 45 ($_url =~ m[^http://]i 46 ? q[Net::BitTorrent::Torrent::Tracker::HTTP] 47 : q[Net::BitTorrent::Torrent::Tracker::UDP] 48 )->new({URL => $_url, Tier => $self}); 49 } 50 weaken($REGISTRY{refaddr $self} = $self); 51 @{$urls{refaddr $self}} = shuffle(@{$urls{refaddr $self}}); 52 return $self; 53 } 54 55 # Accessors | Public 56 sub urls { return $urls{refaddr +shift}; } 57 58 # Accessors | Private 59 sub _client { return $torrent{refaddr +shift}->_client; } 60 sub _torrent { return $torrent{refaddr +shift}; } 61 62 sub _nodes { 63 my ($self) = @_; 64 return compact(map { $_->_nodes } @{$urls{refaddr $self}}); 65 } 66 67 # Methods | Private 68 sub _shuffle { 69 my ($self) = @_; 70 return ( 71 push(@{$urls{refaddr $self}}, shift(@{$urls{refaddr $self}}))); 72 } 73 74 sub _announce { 75 my ($self, $event) = @_; 76 return if not defined $self; 77 return if not defined $urls{refaddr $self}; 78 return if not scalar @{$urls{refaddr $self}}; 79 return $urls{refaddr $self}->[0]->_announce($event ? $event : ()); 80 } 81 82 sub as_string { 83 my ($self, $advanced) = @_; 84 my $dump = !$advanced ? $$self : sprintf <<'END', 85Net::BitTorrent::Torrent::Tracker 86 87Complete: %d 88Incomplete: %d 89Number of URLs: %d 90 %s 91END 92 scalar(@{$urls{refaddr $self}}), 93 join qq[\r\n ], map { $_->url() } @{$urls{refaddr $self}}; 94 return defined wantarray ? $dump : print STDERR qq[$dump\n]; 95 } 96 97 sub CLONE { 98 for my $_oID (keys %REGISTRY) { 99 my $_obj = $REGISTRY{$_oID}; 100 my $_nID = refaddr $_obj; 101 for (@CONTENTS) { 102 $_->{$_nID} = $_->{$_oID}; 103 delete $_->{$_oID}; 104 } 105 weaken $torrent{$_nID}; 106 weaken($REGISTRY{$_nID} = $_obj); 107 delete $REGISTRY{$_oID}; 108 } 109 return 1; 110 } 111 DESTROY { 112 my ($self) = @_; 113 for (@CONTENTS) { delete $_->{refaddr $self}; } 114 return delete $REGISTRY{refaddr $self}; 115 } 116 1; 117} 118 119=pod 120 121=head1 NAME 122 123Net::BitTorrent::Torrent::Tracker - Single BitTorrent Tracker Tier 124 125=head1 Description 126 127Objects of this class should not be created directly. 128 129=head1 Methods 130 131=over 132 133=item C<new()> 134 135Constructor. Don't use this. 136 137=item C<complete()> 138 139Returns the number of complete seeds the tracker says are present in the 140swarm. 141 142=item C<incomplete()> 143 144Returns the number of incomplete peers the tracker says are present in 145the swarm. 146 147=item C<urls()> 148 149Returns a list of related 150L<Net::BitTorrent::Torrent::Tracker::HTTP|Net::BitTorrent::Torrent::Tracker::HTTP> 151and L<Net::BitTorrent::Torrent::Tracker::UDP|Net::BitTorrent::Torrent::Tracker::UDP> 152objects. 153 154=item C<as_string ( [ VERBOSE ] )> 155 156Returns a 'ready to print' dump of the object's data structure. If 157called in void context, the structure is printed to C<STDERR>. 158C<VERBOSE> is a boolean value. 159 160=back 161 162=head1 Author 163 164Sanko Robinson <sanko@cpan.org> - http://sankorobinson.com/ 165 166CPAN ID: SANKO 167 168=head1 License and Legal 169 170Copyright (C) 2008-2009 by Sanko Robinson E<lt>sanko@cpan.orgE<gt> 171 172This program is free software; you can redistribute it and/or modify 173it under the terms of The Artistic License 2.0. See the F<LICENSE> 174file included with this distribution or 175http://www.perlfoundation.org/artistic_license_2_0. For 176clarification, see http://www.perlfoundation.org/artistic_2_0_notes. 177 178When separated from the distribution, all POD documentation is covered 179by the Creative Commons Attribution-Share Alike 3.0 License. See 180http://creativecommons.org/licenses/by-sa/3.0/us/legalcode. For 181clarification, see http://creativecommons.org/licenses/by-sa/3.0/us/. 182 183Neither this module nor the L<Author|/Author> is affiliated with 184BitTorrent, Inc. 185 186=for svn $Id: Tracker.pm d3c97de 2009-09-12 04:31:46Z sanko@cpan.org $ 187 188=cut 189