summaryrefslogtreecommitdiff
path: root/lib/POE
diff options
context:
space:
mode:
authorYorhel <git@yorhel.nl>2009-12-28 16:34:19 +0100
committerYorhel <git@yorhel.nl>2009-12-28 16:37:08 +0100
commit0047ec5695bb7fa38608d380f0ccb24099b7ce82 (patch)
tree829c2e76b7fb14742f93c3e12f4e7725014daf53 /lib/POE
parentd67ace81d3dc6abace9fb22958f906b641acb51c (diff)
Rewrote POE::Filter::VNDBAPI to be more generic
A POE::Filter shouldn't do anything more than parsing incoming data into perl structures and vice versa. The previous implementation had too much logic in the filter itself, which has now been moved into Multi::Anime.
Diffstat (limited to 'lib/POE')
-rw-r--r--lib/POE/Filter/VNDBAPI.pm135
1 files changed, 54 insertions, 81 deletions
diff --git a/lib/POE/Filter/VNDBAPI.pm b/lib/POE/Filter/VNDBAPI.pm
index 24188a2f..816643d9 100644
--- a/lib/POE/Filter/VNDBAPI.pm
+++ b/lib/POE/Filter/VNDBAPI.pm
@@ -1,35 +1,24 @@
# Implements a POE::Filter for the VNDB API, and includes basic error checking
#
-# Currently recognised commands and their mapping between Perl and strings
-# (this is just a simple overview, actual implementation is more advanced)
+# Mapping between the request/response data and perl data structure:
#
-# C: login <json-object>
-# [ 'login', {object} ]
+# <command> -> [ '<command>' ]
#
-# C: get <type> <info> <filters> <options>
-# [ 'get', <type>, <info>[ split ',', $2 ], [ filters ], { options } ]
-# <type> must match /[a-z\/_]+/
-# <info> as string: /[a-z_]+(,[a-z_]+)*/, in perl: [ /[a-z_]+/, .. ]
-# <options> is optional, must be JSON-object otherwise
+# <command> <arg1> <arg2> .. -> [ 'command', <arg1>, <arg2>, .. ]
#
-# S: ok
-# [ 'ok' ]
+# <arg>: <JSON-text> | <filter> | <unescaped-string>
#
-# S: results <json-object>
-# [ 'results', {object} ]
+# <JSON-text>: JSON object or array -> perl object or array
#
-# S: error <json-object>
-# [ 'error', {object} ]
-#
-# <filters>:
+# <filter>:
# string: ((<field> <op> <json-value>) <bool-op> (<field> <op> <json-value> ))
-# perl: [ [ 'field', 'op', value ], 'bool-op', [ 'field', 'op', value ] ]
+# perl: bless [ [ 'field', 'op', value ], 'bool-op', [ 'field', 'op', value ] ], 'POE::Filter::VNDBAPI::filter'
# <field> must match /[a-z_]+/
# <op> must be one of =, !=, <, >, >=, <= or ~
# whitespace around fields/ops/json-values/bool-ops are ignored.
#
-# When type='server', put() will accept the objects marked by 'S' and get() will accept the strings marked by 'C'
-# When type='client', put() will accept the objects marked by 'C' and get() will accept the strings marked by 'S'
+# <unescaped-string>: Any string not starting with (, [ or { and not containing
+# whitespace. In perl represented as a normal string.
#
# When invalid data is given to put(), ...don't do that, seriously.
# When invalid data is given to get(), it will return the following arrayref:
@@ -56,8 +45,6 @@ our @EXPORT_OK = qw|decode_filters encode_filters|;
my $EOT = "\x04"; # End Of Transmission, this string is searched in the binary data using index()
my $WS = qr/[\x20\x09\x0a\x0d]/; # witespace as defined by RFC4627
-my $GET_TYPE = qr/(?:[a-z\/_]+)/; # get <type>
-my $GET_INFO = qr/(?:[a-z_]+(?:,[a-z_]+)*)/; # get <info>
my $FILTER_FIELD = qr/(?:[a-z_]+)/; # <field> in the filters
my $FILTER_OP = qr/(?:=|!=|<|>|>=|<=|~)/; # <op> in the filters
my $FILTER_BOOL = qr/(?:and|or)/; # <boolean-op> in the filters
@@ -65,19 +52,15 @@ my $FILTER_BOOL = qr/(?:and|or)/; # <boolean-op> in the filters
sub new {
my($class, %o) = @_;
- my $type = ($o{type}||'') eq 'server' ? 'server' : 'client';
- return bless {
- type => $type,
- buffer => ''
- }, $class;
+ my $b = '';
+ return bless \$b, $class;
}
sub clone {
my $self = shift;
- return bless {
- type => $self->{type},
- }, ref $self;
+ my $b = '';
+ return bless \$b, ref $self;
}
@@ -98,13 +81,13 @@ sub get {
sub get_one_start {
my($self, $data) = @_;
- $self->{buffer} .= join '', @$data;
+ $$self .= join '', @$data;
}
sub get_pending {
my $self = shift;
- return $self->{buffer} ne '' ? [ $self->{buffer} ] : undef;
+ return $$self ne '' ? [ $$self ] : undef;
}
@@ -113,53 +96,52 @@ sub _err($) { [ [ undef, { id => 'parse', msg => $_[0] } ] ] };
sub get_one {
my $self = shift;
# look for EOT
- my $end = index $self->{buffer}, $EOT;
+ my $end = index $$self, $EOT;
return [] if $end < 0;
- my $str = substr $self->{buffer}, 0, $end;
- $self->{buffer} = substr $self->{buffer}, $end+1;
+ my $str = substr $$self, 0, $end;
+ $$self = substr $$self, $end+1;
# $str now contains our request/response encoded in UTF8, time to decode
$str = eval { decode_utf8($str, Encode::FB_CROAK); };
return _err "Encoding error: $@" if !defined $str;
- # C: login
- # S: error, results
- if($str =~ /^$WS*(login|error|results)$WS+(.+)$/s && ($self->{type} eq 'server' && $1 eq 'login' || $self->{type} eq 'client' && $1 ne 'login')) {
- my($cmd, $json) = ($1, $2);
- $json = eval { JSON::XS->new->decode($json) };
- if(!defined $json) {
- my $err = $@;
- $err =~ s/,? at .+ line [0-9]+[\.\r\n ]*$//;
- return _err "JSON-decode: $err";
- }
- return _err qq|"$cmd" command requires a JSON object| if ref($json) ne 'HASH';
- return [[ $cmd, $json ]];
- }
+ # get command
+ return _err "Invalid command" if !($str =~ s/^$WS*([a-z]+)$WS*//);
+ my @ret = ($1);
+
+ # parse arguments
+ while($str) {
+ $str =~ s/^$WS*//;
- # C: get
- if($self->{type} eq 'server' && $str =~ /^$WS*get$WS+($GET_TYPE)$WS+($GET_INFO)$WS+(.+)$/s) {
- my($type, $info, $options) = ($1, $2, {});
- my($filters, $rest) = decode_filters($3);
- return _err $filters if !ref $filters;
- if($rest !~ /^$WS*$/) {
- $options = eval { JSON::XS->new->decode($rest) };
- if(!defined $options) {
+ # JSON text, starts with { or [
+ if($str =~ /^[\[{]/) {
+ my($value, $chars) = eval { JSON::XS->new->decode_prefix($str) };
+ if(!defined $chars) {
my $err = $@;
$err =~ s/,? at .+ line [0-9]+[\.\r\n ]*$//;
- return _err "JSON-decode: $err";
+ return _err "Invalid JSON value in filter expression: $err";
}
- return _err 'options argument must be a JSON object' if ref($options) ne 'HASH';
+ $str = substr $str, $chars;
+ push @ret, $value;
+ }
+
+ # filter expression, starts with (
+ elsif($str =~ /^\(/) {
+ my($value, $rest) = decode_filters($str);
+ return _err $value if !ref $value;
+ $str = $rest;
+ push @ret, bless $value, 'POE::Filter::VNDBAPI::filter';
}
- return [[ 'get', $type, [ split /,/, $info ], $filters, $options ]];
- }
- # S: ok
- if($self->{type} eq 'client' && $str =~ /^$WS*ok$WS*$/) {
- return [[ 'ok' ]];
+ # otherwise it's an unescaped string
+ else {
+ my ($value, $rest) = split /$WS+/, $str, 2;
+ $str = $rest;
+ push @ret, $value;
+ }
}
- # if we're here, we've received something strange
- return _err 'Invalid command or argument';
+ return [ \@ret ];
}
@@ -170,22 +152,13 @@ sub put {
my @r;
for my $p (@$cmds) {
my $cmd = shift @$p;
-
- # C: login
- push @r, 'login '.JSON::XS->new->encode($p->[0])
- if $self->{type} eq 'client' && $cmd eq 'login';
-
- # C: get
- push @r, sprintf 'get %s %s %s', $p->[0], join(',',@{$p->[1]}), encode_filters($p->[2])
- if $self->{type} eq 'client' && $cmd eq 'get';
-
- # S: ok
- push @r, 'ok'
- if $self->{type} eq 'server' && $cmd eq 'ok';
-
- # S: error, results
- push @r, "$cmd ".JSON::XS->new->encode($p->[0])
- if $self->{type} eq 'server' && ($cmd eq 'error' || $cmd eq 'results');
+ for (@$p) {
+ $cmd .= ' '.(
+ ref($_) eq 'POE::Filter::VNDBAPI::filter' ? encode_filters $_ :
+ ref($_) eq 'ARRAY' || ref($_) eq 'HASH' ? JSON::XS->new->encode($_) : $_
+ );
+ }
+ push @r, $cmd;
}
# the $EOT can also be passed through encode_utf8(), the result is the same.
return [ map encode_utf8($_).$EOT, @r ];