Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Add the main client interface, some documentation, and do some refact…

…oring
  • Loading branch information...
commit 8b5f457ed39c4af61e4ec37c2bca5a62e8bb2736 1 parent 71d764b
@Kulag authored
View
4 Build.PL
@@ -11,7 +11,9 @@ Module::Build->new(
'perl' => '5.010',
'AnyEvent' => '5.0',
'autovivification' => 0,
+ 'B::Hooks::EndOfScope'=> 0,
'common::sense' => 0,
+ 'Class::AutoloadCAN'=> 0,
'Exporter::Tidy' => 0,
'IO::Socket::INET' => 0,
'IO::Uncompress::Inflate'=>0,
@@ -19,9 +21,11 @@ Module::Build->new(
'List::Util' => 0,
'Log::Any::Sugar' => 0,
'MRO::Compat' => 0,
+ 'namespace::clean' => 0,
'Object::Event' => 0,
'Package::Stash' => 0,
'Scalar::Util' => 0,
+ 'Sub::Call::Tail' => 0,
'Time::HiRes' => 0,
'POE::Queue::Array' => 0,
},
View
10 MANIFEST
@@ -1,25 +1,25 @@
Build.PL
lib/Anitie.pm
lib/Anitie/Base.pm
-lib/Anitie/Connection/Encrypted.pm
+lib/Anitie/Connection/UDP.pm
lib/Anitie/Client.pm
-lib/Anitie/Client/Requests.pm
-lib/Anitie/Client/Responses.pm
lib/Anitie/Oracle.pm
lib/Anitie/Payload.pm
lib/Anitie/Protocol.pm
lib/Anitie/Request.pm
lib/Anitie/Request/Ping.pm
lib/Anitie/Request/Uptime.pm
-lib/Anitie/Requests.pm
lib/Anitie/Response.pm
+lib/Anitie/Tags.pm
+lib/Anitie/Transaction.pm
lib/Anitie/Util.pm
MANIFEST This list of files
t/base.t
t/client_online.t
t/oracle.t
t/protocol.t
-t/request.t
+t/tags.t
+t/transaction.t
t/udp.t
t/util.t
t/util_fieldmapper.t
View
273 lib/Anitie/Client.pm
@@ -1,17 +1,19 @@
package Anitie::Client;
use AnyEvent;
+use Class::AutoloadCAN;
use Encode;
use IO::Socket::INET;
use IO::Uncompress::Inflate ();
use Log::Any::Sugar qw(:CAPS);
-use Scalar::Util 'blessed';
+use POE::Queue::Array;
+use Sub::Call::Tail;
use Time::HiRes;
use Anitie::Base Object::Event;
-use Anitie::Client::Requests;
-use Anitie::Client::Responses;
use Anitie::Connection::UDP;
use Anitie::Oracle;
+use Anitie::Tags;
+use Anitie::Transaction;
sub ANIDB_API_HOSTNAME() { 'api.anidb.info' }
sub ANIDB_API_PORT() { 9000 }
@@ -23,13 +25,7 @@ sub REQUEST_ATTEMPT_MAX() { 5 }
has_many qw(api_password encryption local_port user_name user_password);
-=head2 C<request_timeout>
-The default request timeout for requests. Default: 10 seconds.
-=cut
has request_timeout => 10;
-=head2 C<retry_on_timeout>
-Controls whether to retry a request that times out. Default: true.
-=cut
has retry_on_timeout => 1;
has server_name => ANIDB_API_HOSTNAME;
@@ -48,30 +44,72 @@ has 'connection', -init => q{
)
};
has 'oracle', -init => 'Anitie::Oracle->new';
-has 'requests', -init => 'Anitie::Client::Requests->new';
-has 'responses', -init => 'Anitie::Client::Responses->new(client => $self)';
+has pending => {};
+has 'queue', -init => 'POE::Queue::Array->new';
+has 'tags', -init => 'Anitie::Tags->new';
has '_send_timer';
+has '_auth_tx';
sub BUILD { $_[0]->init_object_events }
# Interface
-sub request {
+sub CAN {
+ my ($class, $method, $self, @args) = @_;
+
+ # Ensure the request type exists.
+ eval { Anitie::Transaction::req_type($method) };
+ return if $@ =~ /Can't find plugin/;
+
+ # Build and install a method for the request type.
+ return *{$method} = sub {
+ my $self = shift;
+ $self->start($self->build_tx($method, @_))
+ }
+}
+
+sub build_tx {
my $self = shift;
-
- my $req = blessed $_[0] && $_[0]->isa('Anitie::Request') ? shift : $self->requests->load(shift)->new(@_);
- # Queue it.
- $self->requests->enqueue($req);
+ my $tx = Anitie::Transaction->new;
+
+ # Determine if the user wants a nonblocking request.
+ my $blocking = 1;
+ my $ref = ref $_[-1];
+ if (defined $ref && ($ref eq 'CODE' || $_[-1]->isa('AnyEvent::CondVar'))) {
+ # Last arg is an on_finish callback.
+ $blocking--;
+ $tx->on_finish(pop @_);
+ }
+
+ my $req = $tx->build_req(@_)->req;
+ $req->tag($self->tags->next) unless $req->tag;
+
+ # TODO: Client default values.
+
+ wantarray ? ($tx, $blocking) : $tx;
+}
+
+sub start {
+ my ($self, $tx, $blocking) = @_;
# Initiate connection.
$self->connection;
- DEBUGC { 'Queued a "%s" command.', $req->name };
+ # Enqueue
+ $self->_enqueue($tx);
+
+ DEBUGC { 'Queued a "%s" request.', $tx->req->name };
# Start the request.
$self->{_send_timer} or $self->_schedule;
- $req;
+ # Block until the request is finished if the user wants.
+ if ($blocking) {
+ $tx->on_finish(my $cv = AE::cv);
+ $cv->recv;
+ }
+
+ $tx;
}
# Internal
@@ -87,26 +125,26 @@ sub _schedule {
sub _process_queue {
my $self = shift;
- if (my $req = $self->requests->dequeue) {
- $self->requests->enqueue($req) and return unless $self->_authorize_request($req);
-
- $self->_send_request($req)->check_timeout($req);
- }
-
- $self->requests->queuelen and $self->_schedule or $self->_send_timer(undef);
-}
+ if (my $tx = $self->_dequeue) {
+ my $req = $tx->req;
-sub _authorize_request {
- my ($self, $req) = @_;
- if (!$req->is_anonymous) {
- if (!$self->authenticated) {
- $self->_auth unless $self->authenticating;
- $self->_schedule;
- return;
+ if (!$req->is_anonymous) {
+ if (!$self->authenticated) {
+ my $auth_tx = $self->_auth_tx or $self->_auth;
+ $auth_tx->on_finish(sub { $self->_enqueue($tx) });
+ tail $self->_process_queue;
+ }
+ $req->session_key($self->session_key);
}
- $req->session_key($self->session_key);
+
+ $self->_send_request($req);
+ $tx->{tries}++;
+ $self->_tell_oracle($req->is_anonymous ? 'anonymous request' : 'authenticated request');
+ $self->pending->{$req->tag} = $tx;
+ $self->_check_timeout($tx);
}
- 1;
+
+ $self->_queuelen and $self->_schedule or $self->_send_timer(undef);
}
sub _auth {
@@ -120,20 +158,19 @@ sub _auth {
unless ($self->api_password) {
croak q/Can't enable encryption without API password./;
}
- $self->request('encrypt', user => $self->user_name, type => $self->encryption, priority => 'realtime');
- }
- else {
- $self->request('auth',
- user => $self->user_name,
- pass => $self->user_password,
- protover => PROTOCOL_VERSION,
- client => CLIENT_NAME,
- clientver => CLIENT_VERSION,
- imgserver => 1,
- priority => 'realtime',
- );
+ return $self->encrypt(user => $self->user_name, type => $self->encryption, priority => 'realtime', sub { $self->_auth_tx(undef) });
}
- $self;
+
+ return $self->auth(
+ user => $self->user_name,
+ pass => $self->user_password,
+ protover => PROTOCOL_VERSION,
+ client => CLIENT_NAME,
+ clientver => CLIENT_VERSION,
+ imgserver => 1,
+ priority => 'realtime',
+ sub { $self->_auth_tx(undef) }
+ );
}
sub _send_request {
@@ -150,28 +187,26 @@ sub _send_request {
}
}
$self->connection->send($datagram);
- $req->{send_attempts}++;
- $self->tell_oracle($req->is_anonymous ? 'anonymous request' : 'authenticated request')
- ->requests->pending->{$req->tag} = $req;
$self;
}
-sub check_timeout {
- my ($self, $req) = @_;
- my $timeout = AE::timer $req->timeout || $self->request_timeout, 0,
+sub _check_timeout {
+ my ($self, $tx) = @_;
+ my $timeout = AE::timer $tx->timeout || $self->request_timeout, 0,
$self->retry_on_timeout
? sub {
- DEBUGF 'Checking timeout on %s:%s.', $req->tag, $req->name;
- return if $req->is_done;
- $self->request($req);
+ DEBUGC { 'Checking timeout on %s:%s.', $tx->req->tag, $tx->req->name };
+ return if $tx->finished;
+ $self->start($tx);
# TODO: Do something to handle situations where there are way too many retries.
}
: sub {
- DEBUGF 'Checking timeout on %s:%s.', $req->tag, $req->name;
- return if $req->is_done;
- $req->event('timeout');
+ DEBUGC { 'Checking timeout on %s:%s.', $tx->req->tag, $tx->req->name };
+ return if $tx->finished;
+ $tx->event('finish');
+ $tx->event('timeout');
};
- $req->reg_cb(finish => sub {undef $timeout});
+ $tx->on_finish(sub {undef $timeout});
}
sub _process_response {
@@ -189,10 +224,35 @@ sub _process_response {
}
DEBUG 'IO<< ' . $datagram;
- my $res = $self->responses->parse(decode_utf8($datagram));
- $self->event('res_' . $res->name, $res);
- $res->req->event($res->name, $res);
- $res->req->event('finish', $res);
+
+ $datagram = decode_utf8 $datagram;
+
+ my $tx;
+ # Check for a tag.
+ if ($datagram =~ s/^(?:(\D\S*?)\s+)//) {
+ $tx = delete $self->pending->{$1};
+
+ # TODO: FIXME?
+ # Can happen if a response is received after its command timed out and got resent.
+ WARN q/Received a tagged response without a corresponding command./
+ if not $tx;
+ }
+ else {
+ # No tag, may be a notification type.
+ $tx = Anitie::Transaction->new;
+ }
+
+ # Free the tag
+ $self->tags->free($1);
+
+ # Parse
+ $tx->parse_res($datagram);
+
+ # Dispatch
+ my $name = $tx->res->name;
+ $self->event('res_' . $name, $tx);
+ $tx->event('finish');
+ $tx->event($name);
}
# Status
@@ -200,13 +260,7 @@ sub authenticated {
my $self = shift;
$self->session_key && $self->connected && (!$self->encryption || $self->cipher);
}
-sub authenticating {
- my $self = shift;
- for (values %{$self->requests->queue}) {
- return 1 if $_->name eq 'auth' || $_->name eq 'encrypt';
- }
- return 0;
-}
+sub authenticating { $_[0]->_auth_tx ? 1 : 0 }
sub connected { $_[0]->oracle->connected }
# Internal readability functions.
@@ -216,19 +270,21 @@ sub _clear_session {
$self;
}
-sub tell_oracle {
- $_[0]->oracle->tell($_[1]);
- $_[0];
-}
+sub _tell_oracle { $_[0]->oracle->tell($_[1]); $_[0] }
+
+sub _enqueue { $_[0]->queue->enqueue($_[1]->get_priority, $_[1]); $_[0] }
+sub _dequeue { ($_[0]->queue->dequeue_next)[2] }
+sub _queuelen { $_[0]->queue->get_item_count }
+sub _idle { not ($_[0]->queuelen or keys %{$_[0]->pending}) }
# Internal event handling.
sub res_login_accepted :event_cb {
- shift->session_key(shift->session_key)->tell_oracle('logged in');
+ $_[0]->session_key($_[1]->res->session_key)->_tell_oracle('logged in');
INFO 'Logged in.';
}
sub res_login_accepted_new_client_version_available :event_cb {
- shift->session_key(shift->session_key)->tell_oracle('logged in');
+ $_[0]->session_key($_[1]->res->session_key)->_tell_oracle('logged in');
INFO 'Logged in.';
NOTICE 'There is a new version of Anitie available.';
}
@@ -259,12 +315,12 @@ sub res_login_failed :event_cb {
}
sub res_login_first :event_cb {
- $_[0]->_clear_session->request($_[1]->request);
+ $_[0]->_clear_session->start($_[1]);
DEBUG 'Was told to login first.';
}
sub res_access_denied :event_cb {
- ERRORF '%s:%s: Access denied.', $_[1]->tag, $_[1]->command->type;
+ ERRORF '%s:%s: Access denied.', $_[1]->req->tag, $_[1]->req->name;
}
sub res_client_version_outdated :event_cb {
@@ -280,11 +336,64 @@ sub res_illegal_input :event_cb {
}
sub res_invalid_session :event_cb {
- $_[0]->_clear_session->request->queue($_[1]->request);
+ $_[0]->_clear_session->start($_[1]);
DEBUG 'Was told I had an invalid session.';
}
sub res_anidb_out_of_service :event_cb {
my $oracle = $_[0]->oracle->tell('out of service');
INFOC { 'AniDB is currently out of service, will try to reestablish contact in %d minutes.', $oracle->next_packet / 60 };
-}
+}
+
+=head1 NAME
+
+Anitie::Client - Non-blocking client for AniDB's UDP API
+
+=head1 ATTRIBUTES
+
+=head2 C<request_timeout>
+The default request timeout for requests. Default: 10 seconds.
+
+=head2 C<retry_on_timeout>
+Controls whether to retry a request that times out. Default: true.
+
+=head1 METHODS
+
+=head2 C<authenticating>
+
+ my $auth = $client->authenticating;
+
+True if an AUTH request is in progress.
+
+=head2 C<build_tx>
+
+ my ($tx, $blocking) = $client->build_tx($request_type, @request_args, $optional_callback);
+ my $tx = $client->build_tx('ping', 1, sub {
+ my $tx = shift;
+ });
+
+Builds an L<Anitie::Transaction> and request. The callback will be called when the transaction is finished. $blocking will be true if a callback was passed.
+
+=head2 C<CAN>
+
+ my $tx = $client->$request_type(@request_arguments, $optional_callback);
+ my $tx = $client->ping(1, sub {
+ my $tx = shift;
+ });
+ my $tx = $client->uptime; # Blocking request
+ my $tx = $client->uptime(AE::cv)->on_finish(sub { });
+
+Autoloads the request type specified by the method name, and performs a non-blocking request if a callback is present. See also C<build_tx>, C<start>, and L<Anitie::Transaction>.
+
+=head2 C<connected>
+
+ my $connected = $client->connected;
+
+True if there is an active session.
+
+=head2 C<start>
+
+ my $tx = $client->start($tx);
+ my $tx = $client->start($tx, $blocking);
+
+Starts an L<Anitie::Transaction>, optionally blocking until the transaction finishes.
View
61 lib/Anitie/Client/Requests.pm
@@ -1,61 +0,0 @@
-package Anitie::Client::Requests;
-use Log::Any::Sugar qw(:CAPS);
-use POE::Queue::Array;
-
-use Anitie::Base 'Anitie::Requests';
-
-sub TAG_RANGE() { 2**32 }
-
-has 'queue', -init => 'POE::Queue::Array->new';
-has pending => {};
-has used_tags => [];
-
-sub enqueue {
- my ($self, $req) = @_;
-
- # Ensure the request is tagged.
- $req->tag($self->get_tag) unless $req->tag;
-
- # Enqueue
- $self->queue->enqueue($req->get_priority, $req);
-
- $self;
-}
-
-sub dequeue { ($_[0]->queue->dequeue_next)[2] }
-sub queuelen { $_[0]->queue->get_item_count }
-sub empty { not ($_[0]->queuelen or keys %{$_[0]->pending}) }
-
-sub finish_pending_request {
- my ($self, $tag) = @_;
- if (my $req = delete $self->pending->{$tag}) {
- return $req->is_done(1);
- }
- else {
- # Can happen if a response is received after its command timed out and got resent.
- WARN q/Received a tagged response without a corresponding command./;
- }
-}
-
-sub get_tag {
- my ($self) = @_;
- my $used = $self->used_tags;
- $self->rebuild_used_tag_list if @$used >= TAG_RANGE;
- while (my $tag = int(rand(TAG_RANGE))) {
- unless ($tag ~~ $used) {
- push @{$self->used_tags}, $tag;
- return sprintf('T%x', $tag);
- }
- }
-}
-
-sub rebuild_used_tag_list {
- my ($self) = @_;
- $self->used_tags(
- map { $_->tag } (
- map({ $_[2] } @{$self->queue->peek_items(sub { 1 })}), values %{$self->pending}
- )
- );
-}
-
-1;
View
27 lib/Anitie/Client/Responses.pm
@@ -1,27 +0,0 @@
-package Anitie::Client::Responses;
-use Anitie::Base -base;
-use Anitie::Util qw(plugin_load);
-
-has 'client', -weaken;
-has namespaces => ['Anitie::Response'];
-
-sub load {
- my ($self, $name) = @_;
- plugin_load $name, $self->namespaces, 'Anitie::Response';
-}
-
-sub parse {
- my ($self, $data) = @_;
-
- if ($data =~ s/^(?:(\D\S*) )?(\d+)//) {
- my $res = $self->load($2)->new(tag => $1);
- $res->request($self->client->requests->finish_pending_request($1))
- ->parse($data);
- return $res;
- }
- else {
- croak 'Invalid response: ' . $data;
- }
-}
-
-1;
View
14 lib/Anitie/Protocol.pm
@@ -4,17 +4,23 @@ use Anitie::Base;
use Anitie::Request ();
use Anitie::Response ();
use Anitie::Util qw(camelize decamelize compile_sub);
+use B::Hooks::EndOfScope;
use HTML::Entities ();
+use namespace::clean ();
use Package::Stash ();
use vars qw($BUILD);
+my @builders = qw(anonymous field Bool Int Str required header payload conditional arg_sugar request response);
sub import {
my $caller = caller;
common::sense->import;
- for (qw(anonymous field Bool Int Str required header payload conditional request response)) {
+ for (@builders) {
*{"${caller}::$_"} = *{"Anitie::Protocol::$_"};
}
+ on_scope_end {
+ namespace::clean->clean_subroutines($caller, @builders);
+ }
}
sub anonymous(;$) { $BUILD->{anonymous} = shift // 1 }
@@ -40,6 +46,7 @@ sub parser(&) { $BUILD->{parser} = shift }
sub header(&) { $BUILD->{header} = do { local $BUILD; shift->(); $BUILD } }
sub payload(&) { $BUILD->{payload} = do { local $BUILD; shift->(); $BUILD } }
sub conditional($) { $BUILD->{conditional} = shift }
+sub arg_sugar(&) { $BUILD->{arg_sugar} = shift }
# Perl's regex engine is non-reentrant, so replacements inside grammars must be done with this.
# It's still only about half as fast as $string =~ s/$replace/$with/g;
@@ -247,6 +254,7 @@ sub export_request($$) {
# Export the name and default functions.
export_const $stash, 'name', $BUILD->{name};
export_const $stash, 'is_anonymous', 1 if $BUILD->{anonymous};
+ export_add $stash, '&arg_sugar', $BUILD->{arg_sugar} if exists $BUILD->{arg_sugar};
export_request_is_valid $stash, $BUILD->{fields};
export_request_stringifier $stash, $BUILD->{name}, $BUILD->{fields};
if ($BUILD->{parser}) {
@@ -310,7 +318,7 @@ my %res_str = (
pload_multi => 'for my $payload (@{$_[0]->payload}) {my $mpstr;',
pload_multi_end => "\$pstr .= substr(\$mpstr, 1) . '\n';}",
pfield => '$payload->{%s}',
- conditional => 'my $request = $_[0]->request;',
+ conditional => 'my $request = $_[0]->req;',
cond_setup => 'my %%%s; @%s{do {%s}} = ();',
cond_field => 'if (exists $%s{%s}) {',
cond_addstr => '$hstr .= \'%s%s\';',
@@ -446,7 +454,7 @@ sub export_response_stringifier($$$$$) {
}
my %res_pb = (
- start => 'my ($self, $buf) = @_; state %stash; my $request = $self->request;',
+ start => 'my ($self) = @_; state %stash; my $request = $self->req;',
fieldnames => 'my @%s = qw(%s);',
cond_fieldnames => 'my @%s = do { %s };',
# If the do BLOCK returns nothing, @%s will actually be an array with a single undef element, so check for that here.
View
45 lib/Anitie/Request.pm
@@ -1,28 +1,5 @@
package Anitie::Request;
-use Anitie::Base Object::Event;
-
-sub BUILD { $_[0]->init_object_events }
-
-sub timeout { }
-
-my %PRIORITY = (
- realtime => 0,
- veryhigh => 2**8,
- high => 2**16,
- normal => 2**24,
- low => 2**32,
- verylow => 2**40,
- batch => 2**48,
-);
-sub tr_priority($) {
- return $_[0] if $_[0] =~ /^\d+$/;
- if (defined (my $p = $PRIORITY{$_[0]})) {
- return $p;
- }
- else {
- croak qq{Unknown priority string "$_[0]"};
- }
-}
+use Anitie::Base -base;
# Fields common to all requests.
has_many qw(s tag);
@@ -30,19 +7,6 @@ has_many qw(s tag);
# Alias the session key argument.
*session_key = *s;
-# Client attrs.
-has cb => {};
-has 'is_done';
-has send_attempts => 0;
-has 'priority', -init => 'Anitie::Request::tr_priority($self->default_priority)', -onset => '$self->priority(Anitie::Request::tr_priority($_[1]))';
-
-# Pretend we're an Anitie::Command
-sub has_tag { defined shift->tag }
-sub has_sender {defined shift->sender}
-has 'sender';
-sub callbacks {goto &cb}
-sub does { return 1 if $_[1] eq 'Anitie::Command' }
-
# Default request attributes
sub is_anonymous { 0 }
sub default_priority() { 'normal' }
@@ -53,12 +17,7 @@ sub is_valid {
$self->is_anonymous or defined $self->session_key
}
-sub get_priority {
- my $self = shift;
- return int($self->priority / ($self->send_attempts + 1));
-}
-
-sub _parse {
+sub parse {
my ($self, $args) = @_;
# Regexp::Grammars cannot handle utf8 strings, encode any we get.
View
1  lib/Anitie/Request/Ping.pm
@@ -3,6 +3,7 @@ use Anitie::Protocol;
request {
anonymous;
Bool 'nat';
+ arg_sugar { nat => shift };
};
response {
payload {
View
25 lib/Anitie/Requests.pm
@@ -1,25 +0,0 @@
-package Anitie::Requests;
-use Anitie::Base -base;
-use Anitie::Util qw(plugin_load);
-
-has namespaces => ['Anitie::Request'];
-
-sub load {
- my ($self, $name) = @_;
- plugin_load $name, $self->namespaces, 'Anitie::Request';
-}
-
-sub parse {
- my ($self, $data) = @_;
-
- if ($data =~ /(?:(\w+)\s+(.+)|(\w+))/) {
- my $req = $self->load(lc $1 or lc $3)->new;
- $req->_parse($2) if $2;
- return $req;
- }
- else {
- croak 'Invalid request: ' . $data;
- }
-}
-
-1;
View
6 lib/Anitie/Response.pm
@@ -2,15 +2,13 @@ package Anitie::Response;
use Anitie::Base -base;
use Log::Any::Sugar ':CAPS';
-has 'request';
has 'payload';
+has 'req', -weaken;
has 'tag';
has 'string';
-*req = *request;
-
sub parse {
- my ($self, $buf) = @_;
+ my ($self, $buf, $req) = @_;
# Regexp::Grammars cannot handle utf8 strings, encode any we get.
if (utf8::is_utf8($buf)) {
View
67 lib/Anitie/Tags.pm
@@ -0,0 +1,67 @@
+package Anitie::Tags;
+use Anitie::Base;
+
+# Make testing easier.
+BEGIN { *MAX_TAG = sub() { 2**32-1 } unless defined *{MAX_TAG}{CODE} }
+
+sub P_USED() { 0 }
+sub P_LAST() { 1 }
+
+sub new { bless [{}, 0], shift }
+
+sub next {
+ my $self = shift;
+
+ # Attempt to allocate the first free tag linearly.
+ my $tag;
+ do {
+ if ($$self[P_LAST] >= MAX_TAG) {
+ # Reset
+ $$self[P_LAST] = 0;
+
+ # Ensure we haven't allocated 2^32-1 tags.
+ croak 'Allocated 2^32-1 tags, please deallocate some first!'
+ if (keys %{$$self[P_USED]} == MAX_TAG);
+ }
+
+ # Generate a tag
+ $tag = sprintf('T%x', ++$$self[P_LAST]);
+ } while (exists $$self[P_USED]{$tag});
+
+ # Register allocation.
+ $$self[P_USED]{$tag} = ();
+
+ $tag;
+}
+
+sub free { delete $_[0][P_USED]{$_[1]}; $_[0] }
+
+1;
+
+=head1 NAME
+
+Anitie::Tags - Tag allocation and tracking
+
+=head1 DESCRIPTION
+
+Provides unique tags of the form T%x suitable for use in tagging AniDB UDP messages.
+
+=head1 METHODS
+
+=head2 C<new>
+
+ my $tags = Anitie::Tags->new;
+
+Create a new instance.
+
+=head2 C<next>
+
+ my $tag = $tags->next;
+
+Returns the next free tag in the sequence.
+
+=head2 C<free>
+
+ $tags->free($tag);
+
+Frees a previously allocated tag for reuse.
View
169 lib/Anitie/Transaction.pm
@@ -0,0 +1,169 @@
+package Anitie::Transaction;
+use Anitie::Base Object::Event;
+use Anitie::Util qw(plugin_load);
+use Class::AutoloadCAN;
+
+my %PRIORITY = (
+ realtime => 0,
+ veryhigh => 8,
+ high => 16,
+ normal => 24,
+ low => 32,
+ verylow => 40,
+ batch => 48,
+);
+
+has 'finished';
+has 'priority',
+ -init => 'Anitie::Transaction::_tr_priority($self->req->default_priority)',
+ -onset => '$self->{priority} = Anitie::Transaction::_tr_priority($_[1])';
+has 'req';
+has 'res';
+has 'retries_on_timeout';
+has 'timeout';
+has 'tries';
+
+# Internal
+sub BUILD { $_[0]->init_object_events }
+
+sub CAN {
+ my ($class, $method, $self, @args) = @_;
+ return unless $method =~ /^on_(.+)/;
+ my $event = $1;
+ return *{$method} = sub { shift->reg_cb($event, @_) };
+}
+
+# Methods
+sub build_req {
+ my $self = shift;
+ my $req = req_type(shift)->new;
+
+ # Attempt to parse the remaining args.
+ my %args;
+ if (my $sugar = $req->can('arg_sugar')) {
+ %args = &$sugar(@_);
+ }
+ else {
+ %args = @_;
+ }
+
+ $req->_init_args(%args);
+
+ $self->req($req);
+}
+
+sub parse_req {
+ my ($self, $data) = @_;
+
+ $data =~ /^(\w+)\s+(.*)/ or croak 'Invalid request: ' . $data;
+ my $req = req_type(lc $1)->new;
+ $req->parse($2) if $2;
+ $self->req($req);
+}
+
+sub parse_res {
+ my ($self, $buf) = @_;
+
+ $buf =~ s/^(\d+) // or croak "Corrupt response: $buf";
+ my $res = res_type($1) or croak "Unknown response ID: $1";
+ $self->res($res->new->req($self->req)->parse($buf));
+}
+
+sub get_priority {
+ my $self = shift;
+ return $self->priority - $self->tries;
+}
+
+# Functions
+sub req_type { plugin_load $_[0], ['Anitie::Request'], 'Anitie::Request' }
+sub res_type { plugin_load $_[0], ['Anitie::Response'], 'Anitie::Response' }
+
+sub _tr_priority($) {
+ my $int = int $_[0];
+ return $int if $int > 0 or $_[0] =~ /^0/;
+ return $PRIORITY{$_[0]} if exists $PRIORITY{$_[0]};
+ croak qq{Unknown priority string "$_[0]"};
+}
+
+sub _finish :event_cb(before,finish) { $_[0]->finished(1) }
+
+=head1 NAME
+
+Anitie::Transaction - AniDB request/response transaction container
+
+=head1 ATTRIBUTES
+
+L<Anitie::Transaction> implements the following attributes.
+
+=head2 C<finished>
+Whether the transaction has been finished or not.
+
+=head2 C<priority>
+Affects the processing order of the request. You may give an integer or one of the following strings: realtime(0), veryhigh, high, normal(24), low, verylow, batch(48). Defaults to normal or the default priority for the request type.
+
+=head2 C<req>
+This transaction's request.
+
+=head2 C<res>
+This transaction's response.
+
+=head2 C<retries_on_timeout>
+The number of times the request will be attempted after timeouts. Overrides the attribute in L<Anitie::Client> for this transaction.
+
+=head2 C<timeout>
+The number of seconds to wait before considering the request timed out. Overrides the attribute in L<Anitie::Client> for this transaction.
+
+=head2 C<tries>
+Number of times the request has been tried.
+
+=head1 METHODS
+
+L<Anitie::Transaction> inherits all methods from L<Anitie::Base> and implements the following new ones.
+
+=head2 C<build_req>
+
+ my $req = $tx->build_req('ping')->req;
+ my $req = $tx->build_req('ping', 1)->req;
+
+Builds a request object of the given type using the given arguments.
+
+=head2 C<CAN>
+
+ my $tx = $tx->on_finish(sub { });
+ my $tx = $tx->on_access_denied(sub { });
+
+on_<event name> methods register event-specific callbacks. The finish event is called on completion of all transactions, and additional events are called based on the name of the response object. See L<Object::Event>'s C<reg_cb> for another method of registering your callbacks.
+
+=head2 C<parse_req>
+
+ my $req = $tx->parse_req("PING\n")->req;
+ my $req = $tx->parse_req("PING nat=1\n")->req;
+
+Parses a request string into a request object.
+
+=head2 C<parse_res>
+
+ my $res = $tx->parse_res("PONG\n")->res;
+ my $res = $tx->parse_res("PONG\n5000\n")->res;
+
+Parses a response string without a tag into a response object.
+
+=head2 C<get_priority>
+
+ my $priority = $tx->get_priority;
+
+Get the priority of the transaction, based on the request's base priority and the number of retries.
+
+=head1 FUNCTIONS
+
+=head2 C<req_type>
+
+ my $req_module = req_type('ping');
+
+Attempts to load the module for a request type.
+
+=head2 C<res_type>
+
+ my $res_module = res_type(300); # PONG
+
+Attempts to load the module for a response type.
View
39 t/client_online.t
@@ -1,3 +1,4 @@
+#!/usr/bin/env perl
use common::sense;
use Test::More;
use Log::Dispatch;
@@ -6,39 +7,43 @@ use AnyEvent;
use AnyEvent::Util;
plan skip_all => 'set TEST_ONLINE to enable this test (developer only!)' unless $ENV{TEST_ONLINE};
-plan tests => 7;
+plan tests => 10;
my $log = Log::Dispatch->new(outputs => [['Screen', min_level => 'debug', newline => 1]]);
Log::Any::Adapter->set('Dispatch', dispatcher => $log);
use_ok 'Anitie::Client';
-use_ok 'Anitie::Requests';
-
-my $r = Anitie::Requests->new;
-my $ping = $r->load('ping');
my $c = Anitie::Client->new(local_port => 5002);
my $cv = AE::cv;
{
+ my ($tx, $blocking) = $c->build_tx('ping', sub {});
+ is $blocking, 0, 'blocking detection works';
+ ($tx, $blocking) = $c->build_tx('ping', AE::cv);
+ is $blocking, 0;
+}
+
+my $res = $c->ping->res;
+ok defined $res, 'res is defined';
+ok $res->isa('Anitie::Response::Pong'), 'got a pong response via blocking method';
+
+{
my $guard = guard { $cv->send };
- my $r = $ping->new;
- $r->reg_cb(pong => sub {
- my ($req, $res) = @_;
- ok $res->isa('Anitie::Response::Pong'), 'got a pong response';
+
+ $c->ping(sub {
+ my $res = shift->res;
+ ok $res->isa('Anitie::Response::Pong'), 'got a pong response via on_finish';
is $res->payload, undef;
$guard;
});
- $c->request($r);
- $r = $ping->new(nat => 1);
- $r->reg_cb(pong => sub {
- my ($req, $res) = @_;
- ok $res->isa('Anitie::Response::Pong'), 'got a pong response';
+
+ $c->ping(1, AE::cv {$guard})->on_pong(sub {
+ my $res = shift->res;
+ ok $res->isa('Anitie::Response::Pong'), 'got a pong response via on_pong';
ok int($res->payload->{port}), 'port is an int';
- $guard;
});
- $c->request($r);
}
$cv->recv;
-is scalar @{$c->oracle->events->{'anonymous request'}}, 2, 'Two anonymous requests in the oracle';
+is scalar @{$c->oracle->events->{'anonymous request'}}, 3, 'Three anonymous requests in the oracle';
View
27 t/tags.t
@@ -0,0 +1,27 @@
+#!/usr/bin/env perl
+use common::sense;
+use Test::Exception;
+use Test::More tests => 105;
+
+# Speed up testing.
+*Anitie::Tags::MAX_TAG = sub() { 100 };
+
+use_ok 'Anitie::Tags';
+
+my $t = Anitie::Tags->new;
+is ref $t, 'Anitie::Tags', 'isa ok';
+
+# Allocate the maximum.
+for (1..100) {
+ is my $a = $t->next, sprintf('T%x', $_);
+}
+
+throws_ok { $t->next } qr/Allocated .+? tags, please deallocate some first/;
+
+my $tag500 = sprintf('T%x', 50);
+$t->free($tag500);
+is $t->next, $tag500, 'next tag is the freed one';
+
+my $tag499 = sprintf('T%x', 49);
+$t->free($tag499);
+is $t->next, $tag499, 'no errors here';
View
33 t/request.t → t/transaction.t
@@ -1,13 +1,14 @@
+#!/usr/bin/env perl
use common::sense;
+use Test::Deep;
use Test::Exception;
-use Test::More tests => 26;
+use Test::More tests => 28;
+use_ok 'Anitie::Transaction';
-use_ok 'Anitie::Requests';
-
-my $a = Anitie::Requests->new;
+my $tx = Anitie::Transaction->new;
# The most basic of parsers.
-my $r = $a->parse('PING nat=1');
+my $r = $tx->parse_req('PING nat=1')->req;
is $r->name, 'ping', 'Ping request recognized';
is $r->nat, 1, 'nat set to true';
is $r->is_anonymous, 1, 'ping is anonymous';
@@ -15,20 +16,24 @@ is $r->session_key, undef, 'session_key undefined';
is $r->tag, undef, 'tag undefined';
is $r->stringify, "PING nat=1\n", 'stringify builder outputs correct';
+# Check the transaction
+is $tx->priority, 24, 'priority normal';
+is $tx->get_priority, 24;
+
# Looks almost right?
-$r = $a->parse("ping NaT = 0&\ttAg=pfd");
+$r = $tx->parse_req("ping NaT = 0&\ttAg=pfd")->req;
is $r->nat, 0, 'nat is false';
is $r->stringify, "PING nat=0&tag=pfd\n", 'stringify builder outputs correct for false';
# More nonsense.
-$r = $a->parse("uptime TAG\t=ifj& S = てすとa\n");
+$r = $tx->parse_req("uptime TAG\t=ifj& S = てすとa\n")->req;
is $r->name, 'uptime', 'uptime request parses';
is $r->session_key, 'てすとa', 'session_key utf8 parsed fine';
is $r->tag, 'ifj', 'tag contains correct data';
is $r->stringify, "UPTIME s=てすとa&tag=ifj\n", 'stringify builder outputs correctly for uptime';
# is_valid generator
-$r = $a->load('uptime')->new;
+$r = Anitie::Transaction::req_type('uptime')->new;
throws_ok {$r->is_valid} qr/required/, 'not valid yet';
lives_ok {$r->s('t')->is_valid}, 'valid now';
@@ -43,12 +48,12 @@ is $r->payload->{uptime}, 500, 'parses uptime payload correctly';
is $r->stringify, "208 UPTIME\n500\n", 'uptime response stringifies correctly';
# Conditional header parsing and stringifying.
-$r = Anitie::Response::Pong->new(request => Anitie::Request::Ping->new());
-$r->parse("PONG\n");
+$tx = Anitie::Transaction->new(req => Anitie::Request::Ping->new);
+$r = $tx->parse_res("300 PONG\n")->res;
is $r->string, 'PONG';
is $r->payload, undef;
is $r->stringify, "300 PONG\n", 'pong with no nat from request stringifies correctly';
-$r->request->nat(1);
-$r->parse("PONG\n5001\n");
-is $r->payload->{port}, 5001;
-is $r->stringify, "300 PONG\n5001\n", 'pong with nat from request enabled stringifies correctly';
+$tx->req->nat(1);
+$r = $tx->parse_res("300 PONG\n5001\n")->res;
+is_deeply $r->payload, {port => 5001};
+is $r->stringify, "300 PONG\n5001\n", 'pong with nat from request enabled stringifies correctly';
Please sign in to comment.
Something went wrong with that request. Please try again.