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