r48206 - in /branches/upstream/libwebservice-solr-perl/current: ./ lib/WebService/ lib/WebService/Solr/ t/ t/request/
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Sat Dec 5 00:33:15 UTC 2009
Author: jawnsy-guest
Date: Sat Dec 5 00:33:08 2009
New Revision: 48206
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=48206
Log:
[svn-upgrade] Integrating new upstream version, libwebservice-solr-perl (0.09)
Added:
branches/upstream/libwebservice-solr-perl/current/t/request/rollback.t
Modified:
branches/upstream/libwebservice-solr-perl/current/Changes
branches/upstream/libwebservice-solr-perl/current/MANIFEST
branches/upstream/libwebservice-solr-perl/current/META.yml
branches/upstream/libwebservice-solr-perl/current/README
branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr.pm
branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr/Document.pm
branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr/Field.pm
branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr/Query.pm
branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr/Response.pm
branches/upstream/libwebservice-solr-perl/current/t/request/delete.t
branches/upstream/libwebservice-solr-perl/current/t/response.t
Modified: branches/upstream/libwebservice-solr-perl/current/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwebservice-solr-perl/current/Changes?rev=48206&op=diff
==============================================================================
--- branches/upstream/libwebservice-solr-perl/current/Changes (original)
+++ branches/upstream/libwebservice-solr-perl/current/Changes Sat Dec 5 00:33:08 2009
@@ -1,4 +1,12 @@
Revision history for Perl extension WebService::Solr.
+
+0.09 Fri Dec 04 2009
+ - Return undef in pager/pageset special case when we explicitly
+ return 0 rows
+ - Add rollback() from Solr 1.4
+ - Add generic delete() from Solr 1.4
+ - Update docs to match Solr 1.4 options
+ - Fix ping() to check only the HTTP status
0.08 Wed Oct 14 2009
- Allow scalar ref value in WebService::Solr::Query, which works like
Modified: branches/upstream/libwebservice-solr-perl/current/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwebservice-solr-perl/current/MANIFEST?rev=48206&op=diff
==============================================================================
--- branches/upstream/libwebservice-solr-perl/current/MANIFEST (original)
+++ branches/upstream/libwebservice-solr-perl/current/MANIFEST Sat Dec 5 00:33:08 2009
@@ -27,6 +27,7 @@
t/request/delete.t
t/request/optimize.t
t/request/ping.t
+t/request/rollback.t
t/request/search.t
t/response.t
t/use.t
Modified: branches/upstream/libwebservice-solr-perl/current/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwebservice-solr-perl/current/META.yml?rev=48206&op=diff
==============================================================================
--- branches/upstream/libwebservice-solr-perl/current/META.yml (original)
+++ branches/upstream/libwebservice-solr-perl/current/META.yml Sat Dec 5 00:33:08 2009
@@ -33,4 +33,4 @@
resources:
license: http://dev.perl.org/licenses/
repository: http://github.com/bricas/webservice-solr
-version: 0.08
+version: 0.09
Modified: branches/upstream/libwebservice-solr-perl/current/README
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwebservice-solr-perl/current/README?rev=48206&op=diff
==============================================================================
--- branches/upstream/libwebservice-solr-perl/current/README (original)
+++ branches/upstream/libwebservice-solr-perl/current/README Sat Dec 5 00:33:08 2009
@@ -11,6 +11,9 @@
}
DESCRIPTION
+ WebService::Solr is a client library for Apache Lucene's Solr; an
+ enterprise-grade indexing and searching platform.
+
ACCESSORS
* url - the webservice base url
@@ -34,12 +37,27 @@
Adds a number of documents to the index. Returns true on success, false
otherwise. A document can be a WebService::Solr::Document object or a
structure that can be passed to "WebService::Solr::Document->new".
- Available options as of Solr 1.3 are:
+ Available options as of Solr 1.4 are:
- * allowDups (default: false) - Allow duplicate entries
+ * overwrite (default: true) - Replace previously added documents with
+ the same uniqueKey
+
+ * commitWithin (in milliseconds) - The document will be added within
+ the specified time
update( $doc|\@docs, \%options )
Alias for "add()".
+
+ delete( \%options )
+ Deletes documents matching the options provided. The delete operation
+ currently accepts "query" and "id" parameters. Multiple values can be
+ specified as array references.
+
+ # delete documents matching "title:bar" or uniqueId 13 or 42
+ $solr->delete( {
+ query => 'title:bar',
+ id => [ 13, 42 ],
+ } );
delete_by_id( $id )
Deletes all documents matching the id specified. Returns true on
@@ -68,18 +86,25 @@
$solr->add( $doc ); # will not automatically call commit()
$solr->commit;
- Options as of Solr 1.3 include:
+ Options as of Solr 1.4 include:
- * maxSegments (default: 1)
+ * maxSegments (default: 1) - Optimizes down to at most this number of
+ segments
- * waitFlush (default: true)
+ * waitFlush (default: true) - Block until index changes are flushed to
+ disk
- * waitSearcher (default: true)
+ * waitSearcher (default: true) - Block until a new searcher is opened
+
+ * expungeDeletes (default: false) - Merge segments with deletes away
+
+ rollback( )
+ This method will rollback any additions/deletions since the last commit.
optimize( \%options )
Sends an optimize command. Returns true on success, false otherwise.
- Options as of Solr 1.3 are the same as "commit()".
+ Options as of Solr 1.4 are the same as "commit()".
ping( )
Sends a basic ping request. Returns true on success, false otherwise.
Modified: branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr.pm?rev=48206&op=diff
==============================================================================
--- branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr.pm (original)
+++ branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr.pm Sat Dec 5 00:33:08 2009
@@ -28,7 +28,15 @@
default => sub { { wt => 'json' } }
);
-our $VERSION = '0.08';
+has '_xml_generator' => (
+ is => 'ro',
+ init_arg => undef,
+ default => sub {
+ XML::Generator->new( ':std', escape => 'always,even-entities' );
+ },
+);
+
+our $VERSION = '0.09';
sub BUILDARGS {
my ( $self, $url, $options ) = @_;
@@ -38,11 +46,9 @@
$options->{ url } = ref $url ? $url : URI->new( $url );
}
- if( exists $options->{ default_params } ) {
- $options->{ default_params } = {
- %{ $options->{ default_params } },
- wt => 'json',
- }
+ if ( exists $options->{ default_params } ) {
+ $options->{ default_params }
+ = { %{ $options->{ default_params } }, wt => 'json', };
}
return $options;
@@ -53,9 +59,7 @@
my @docs = ref $doc eq 'ARRAY' ? @$doc : ( $doc );
$params ||= {};
- my $gen = XML::Generator->new( ':std', escape => 'always,even-entities' );
-
- my $xml = $gen->add(
+ my $xml = $self->_xml_generator->add(
$params,
map {
if ( blessed $_ ) { $_->to_xml }
@@ -77,8 +81,15 @@
sub commit {
my ( $self, $params ) = @_;
$params ||= {};
- my $gen = XML::Generator->new( ':std', escape => 'always,even-entities' );
- my $response = $self->_send_update( $gen->commit( $params ), {}, 0 );
+ my $response
+ = $self->_send_update( $self->_xml_generator->commit( $params ), {},
+ 0 );
+ return $response->ok;
+}
+
+sub rollback {
+ my ( $self ) = @_;
+ my $response = $self->_send_update( '<rollback/>', {}, 0 );
return $response->ok;
}
@@ -87,6 +98,20 @@
$params ||= {};
my $gen = XML::Generator->new( ':std', escape => 'always,even-entities' );
my $response = $self->_send_update( $gen->optimize( $params ), {}, 0 );
+ return $response->ok;
+}
+
+sub delete {
+ my ( $self, $options ) = @_;
+ my $gen = $self->_xml_generator;
+
+ my $xml = '';
+ for my $k ( keys %$options ) {
+ my $v = $options->{ $k };
+ $xml .= $gen->$k( $_ ) for ref $v ? @$v : $v;
+ }
+
+ my $response = $self->_send_update( "<delete>${xml}</delete>" );
return $response->ok;
}
@@ -98,7 +123,7 @@
sub delete_by_query {
my ( $self, $query ) = @_;
- my $gen = XML::Generator->new( ':std', escape => 'always,even-entities' );
+ my $gen = $self->_xml_generator;
my $response
= $self->_send_update( $gen->delete( $gen->query( $query ) ) );
return $response->ok;
@@ -108,9 +133,7 @@
my ( $self ) = @_;
my $response = WebService::Solr::Response->new(
$self->agent->get( $self->_gen_url( 'admin/ping' ) ) );
- return
- exists $response->content->{ status }
- && $response->content->{ status } eq 'OK';
+ return $response->is_success;
}
sub search {
@@ -150,15 +173,15 @@
my $req = HTTP::Request->new(
POST => $url,
HTTP::Headers->new( Content_Type => 'text/xml; charset=utf-8' ),
- '<?xml version="1.0" encoding="UTF-8"?>' . encode('utf8', "$xml")
+ '<?xml version="1.0" encoding="UTF-8"?>' . encode( 'utf8', "$xml" )
);
- my $http_response = $self->agent->request($req);
+ my $http_response = $self->agent->request( $req );
if ( $http_response->is_error ) {
confess $http_response->status_line . ': ' . $http_response->content;
}
- my $res = WebService::Solr::Response->new($http_response);
+ my $res = WebService::Solr::Response->new( $http_response );
$self->commit if $autocommit;
@@ -189,7 +212,8 @@
=head1 DESCRIPTION
-
+WebService::Solr is a client library for Apache Lucene's Solr; an
+enterprise-grade indexing and searching platform.
=head1 ACCESSORS
@@ -222,17 +246,31 @@
Adds a number of documents to the index. Returns true on success, false
otherwise. A document can be a L<WebService::Solr::Document> object or a
structure that can be passed to C<WebService::Solr::Document-E<gt>new>. Available
-options as of Solr 1.3 are:
+options as of Solr 1.4 are:
=over 4
-=item * allowDups (default: false) - Allow duplicate entries
+=item * overwrite (default: true) - Replace previously added documents with the same uniqueKey
+
+=item * commitWithin (in milliseconds) - The document will be added within the specified time
=back
=head2 update( $doc|\@docs, \%options )
Alias for C<add()>.
+
+=head2 delete( \%options )
+
+Deletes documents matching the options provided. The delete operation currently
+accepts C<query> and C<id> parameters. Multiple values can be specified as
+array references.
+
+ # delete documents matching "title:bar" or uniqueId 13 or 42
+ $solr->delete( {
+ query => 'title:bar',
+ id => [ 13, 42 ],
+ } );
=head2 delete_by_id( $id )
@@ -265,23 +303,29 @@
$solr->add( $doc ); # will not automatically call commit()
$solr->commit;
-Options as of Solr 1.3 include:
+Options as of Solr 1.4 include:
=over 4
-=item * maxSegments (default: 1)
-
-=item * waitFlush (default: true)
-
-=item * waitSearcher (default: true)
+=item * maxSegments (default: 1) - Optimizes down to at most this number of segments
+
+=item * waitFlush (default: true) - Block until index changes are flushed to disk
+
+=item * waitSearcher (default: true) - Block until a new searcher is opened
+
+=item * expungeDeletes (default: false) - Merge segments with deletes away
=back
+=head2 rollback( )
+
+This method will rollback any additions/deletions since the last commit.
+
=head2 optimize( \%options )
Sends an optimize command. Returns true on success, false otherwise.
-Options as of Solr 1.3 are the same as C<commit()>.
+Options as of Solr 1.4 are the same as C<commit()>.
=head2 ping( )
Modified: branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr/Document.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr/Document.pm?rev=48206&op=diff
==============================================================================
--- branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr/Document.pm (original)
+++ branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr/Document.pm Sat Dec 5 00:33:08 2009
@@ -41,8 +41,9 @@
}
my $v = shift @fields;
- my @values = ( ref $v and !blessed $v )? @$v : ( "$v" );
- push @new_fields, map { WebService::Solr::Field->new( $f => $_ ) } @values;
+ my @values = ( ref $v and !blessed $v ) ? @$v : ( "$v" );
+ push @new_fields,
+ map { WebService::Solr::Field->new( $f => $_ ) } @values;
}
return @new_fields;
@@ -60,7 +61,7 @@
sub to_xml {
my $self = shift;
- my $gen = XML::Generator->new( ':std', escape => 'always,even-entities' );
+ my $gen = XML::Generator->new( ':std', escape => 'always,even-entities' );
my %attr = ( $self->boost ? ( boost => $self->boost ) : () );
return $gen->doc( \%attr, map { $_->to_xml } $self->fields );
@@ -137,7 +138,7 @@
=head1 COPYRIGHT AND LICENSE
-Copyright 2008 National Adult Literacy Database
+Copyright 2008-2009 National Adult Literacy Database
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
Modified: branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr/Field.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr/Field.pm?rev=48206&op=diff
==============================================================================
--- branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr/Field.pm (original)
+++ branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr/Field.pm Sat Dec 5 00:33:08 2009
@@ -19,7 +19,7 @@
sub to_xml {
my $self = shift;
- my $gen = XML::Generator->new( ':std', escape => 'always,even-entities' );
+ my $gen = XML::Generator->new( ':std', escape => 'always,even-entities' );
my %attr = ( $self->boost ? ( boost => $self->boost ) : () );
return $gen->field( { name => $self->name, %attr }, $self->value );
@@ -81,7 +81,7 @@
=head1 COPYRIGHT AND LICENSE
-Copyright 2008 National Adult Literacy Database
+Copyright 2008-2009 National Adult Literacy Database
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
Modified: branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr/Query.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr/Query.pm?rev=48206&op=diff
==============================================================================
--- branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr/Query.pm (original)
+++ branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr/Query.pm Sat Dec 5 00:33:08 2009
@@ -32,7 +32,7 @@
my $method = '_struct_' . ref $struct;
- D && $self->___log( "Dispatching to ->$method ". Dumper $struct );
+ D && $self->___log( "Dispatching to ->$method " . Dumper $struct );
my $rv = $self->$method( $struct );
@@ -49,23 +49,25 @@
for my $k ( keys %$struct ) {
my $v = $struct->{ $k };
- D && $self->___log("Key => $k, value => ". Dumper($v));
+ D && $self->___log( "Key => $k, value => " . Dumper( $v ) );
if ( $k =~ m{^-(.+)} ) {
my $method = "_op_$1";
- D && $self->___log("Dispatch ->$method ". Dumper($v));
+ D && $self->___log( "Dispatch ->$method " . Dumper( $v ) );
push @clauses, $self->$method( $v );
}
else {
- D && $self->___log("Dispatch ->_dispatch_value $k, ". Dumper($v));
+ D
+ && $self->___log(
+ "Dispatch ->_dispatch_value $k, " . Dumper( $v ) );
push @clauses, $self->_dispatch_value( $k, $v );
}
}
my $rv = join( ' AND ', @clauses );
- D && $self->___log("Returning: $rv");
+ D && $self->___log( "Returning: $rv" );
return $rv;
}
@@ -73,13 +75,13 @@
sub _struct_ARRAY {
my ( $self, $struct ) = @_;
- my $rv =
- '('
+ my $rv
+ = '('
. join( " OR ", map { $self->_dispatch_struct( $_ ) } @$struct )
. ')';
-
- D && $self->___log("Returning: $rv");
-
+
+ D && $self->___log( "Returning: $rv" );
+
return $rv;
}
@@ -92,51 +94,58 @@
# [ '-and',
# { '-require' => 'star' },
# { '-require' => 'wars' }
- # ];
- if( ref $v and UNIVERSAL::isa( $v, 'ARRAY' ) and
- defined $v->[0] and $v->[0] =~ /^ - ( AND|OR ) $/ix
- ) {
+ # ];
+ if ( ref $v
+ and UNIVERSAL::isa( $v, 'ARRAY' )
+ and defined $v->[ 0 ]
+ and $v->[ 0 ] =~ /^ - ( AND|OR ) $/ix )
+ {
### XXX we're assuming that all the next statements MUST
### be hashrefs. is this correct?
shift @$v;
my $op = uc $1;
- D && $self->___log("Special operator detected: $op ". Dumper($v));
+ D
+ && $self->___log(
+ "Special operator detected: $op " . Dumper( $v ) );
my @clauses;
for my $href ( @$v ) {
- D && $self->___log(
- "Dispatch ->_dispatch_struct({ $k, ". Dumper($href) .'})' );
-
- ### the individual directive ($href) pertains to the key,
+ D
+ && $self->___log( "Dispatch ->_dispatch_struct({ $k, "
+ . Dumper( $href )
+ . '})' );
+
+ ### the individual directive ($href) pertains to the key,
### so we should send that along.
my $part = $self->_dispatch_struct( { $k => $href } );
-
+
D && $self->___log( "Returned $part" );
- push @clauses, '('. $part .')';
+ push @clauses, '(' . $part . ')';
}
-
- $rv = '('. join( " $op ", @clauses ) .')';
-
- ### nothing special about this combo, so do a usual dispatch
- } else {
+
+ $rv = '(' . join( " $op ", @clauses ) . ')';
+
+ ### nothing special about this combo, so do a usual dispatch
+ }
+ else {
my $method = '_value_' . ( ref $v || 'SCALAR' );
-
- D && $self->___log("Dispatch ->$method $k, ". Dumper($v));
-
+
+ D && $self->___log( "Dispatch ->$method $k, " . Dumper( $v ) );
+
$rv = $self->$method( $k, $v );
}
-
- D && $self->___log("Returning: $rv");
-
+
+ D && $self->___log( "Returning: $rv" );
+
return $rv;
}
sub _value_SCALAR {
my ( $self, $k, $v ) = @_;
- if( ref $v ) {
+ if ( ref $v ) {
$v = $$v;
}
else {
@@ -146,7 +155,7 @@
my $r = qq($k:$v);
$r =~ s{^:}{};
- D && $self->___log("Returning: $r");
+ D && $self->___log( "Returning: $r" );
return $r;
}
@@ -159,15 +168,15 @@
for my $op ( keys %$v ) {
my $struct = $v->{ $op };
$op =~ s{^-(.+)}{_op_$1};
-
- D && $self->___log("Dispatch ->$op $k, ". Dumper($v));
-
+
+ D && $self->___log( "Dispatch ->$op $k, " . Dumper( $v ) );
+
push @clauses, $self->$op( $k, $struct );
}
my $rv = join( ' AND ', @clauses );
- D && $self->___log("Returning: $rv");
+ D && $self->___log( "Returning: $rv" );
return $rv;
}
@@ -175,12 +184,11 @@
sub _value_ARRAY {
my ( $self, $k, $v ) = @_;
- my $rv =
- '('
+ my $rv = '('
. join( ' OR ', map { $self->_value_SCALAR( $k, $_ ) } @$v ) . ')';
- D && $self->___log("Returning: $rv");
-
+ D && $self->___log( "Returning: $rv" );
+
return $rv;
}
@@ -254,11 +262,11 @@
### subroutine the log call came from, and line number the log
### call came from. that's 2 different caller frames :(
- my $who = join ':', [caller(1)]->[3], [caller(0)]->[2];
-
+ my $who = join ':', [ caller( 1 ) ]->[ 3 ], [ caller( 0 ) ]->[ 2 ];
+
### make sure we prefix every line with a #
$msg =~ s/\n/\n#/g;
-
+
print "# $who: $msg\n";
}
Modified: branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr/Response.pm
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr/Response.pm?rev=48206&op=diff
==============================================================================
--- branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr/Response.pm (original)
+++ branches/upstream/libwebservice-solr-perl/current/lib/WebService/Solr/Response.pm Sat Dec 5 00:33:08 2009
@@ -10,7 +10,7 @@
has 'raw_response' => (
is => 'ro',
isa => 'Object',
- handles => {
+ handles => {
status_code => 'code',
status_message => 'message',
is_success => 'is_success',
@@ -23,10 +23,12 @@
has 'docs' =>
( is => 'rw', isa => 'ArrayRef', auto_deref => 1, lazy_build => 1 );
-has 'pager' => ( is => 'rw', isa => 'Data::Page', lazy_build => 1 );
-
-has '_pageset_slide' => ( is => 'rw', isa => 'Data::Pageset', lazy_build => 1 );
-has '_pageset_fixed' => ( is => 'rw', isa => 'Data::Pageset', lazy_build => 1 );
+has 'pager' => ( is => 'rw', isa => 'Maybe[Data::Page]', lazy_build => 1 );
+
+has '_pageset_slide' =>
+ ( is => 'rw', isa => 'Maybe[Data::Pageset]', lazy_build => 1 );
+has '_pageset_fixed' =>
+ ( is => 'rw', isa => 'Maybe[Data::Pageset]', lazy_build => 1 );
sub BUILDARGS {
my ( $self, $res ) = @_;
@@ -34,15 +36,15 @@
}
sub _build_content {
- my $self = shift;
+ my $self = shift;
my $content = $self->raw_response->content;
return {} unless $content;
my $rv = eval { JSON::XS::decode_json( $content ) };
-
+
### JSON::XS throw an exception, but kills most of the content
### in the diagnostic, making it hard to track down the problem
die "Could not parse JSON response: $@ $content" if $@;
-
+
return $rv;
}
@@ -61,55 +63,72 @@
my $struct = $self->content;
return unless exists $struct->{ response }->{ numFound };
- my $total = $struct->{ response }->{ numFound };
- my $rows = $struct->{ responseHeader }->{ params }->{ rows } || 10;
- my $start = $struct->{ response }->{ start };
+
+ my $rows = $struct->{ responseHeader }->{ params }->{ rows };
+
+ # do not generate a pager for queries explicitly requesting no rows
+ return if defined $rows && $rows == 0;
+
+ # rows not explicitly set, find default from rows returned
+ if ( !defined $rows ) {
+ $rows = scalar @{ $struct->{ response }->{ docs } };
+ }
my $pager = Data::Page->new;
- $pager->total_entries( $total );
+ $pager->total_entries( $struct->{ response }->{ numFound } );
$pager->entries_per_page( $rows );
- $pager->current_page( $start / $rows + 1 );
+ $pager->current_page( $struct->{ response }->{ start } / $rows + 1 );
return $pager;
}
sub pageset {
my $self = shift;
my %args = @_;
-
- my $mode = $args{'mode'} || 'fixed';
- my $meth = "_pageset_". $mode;
- my $pred = "_has".$meth;
-
- ### use a cached version if possilbe
+
+ my $mode = $args{ 'mode' } || 'fixed';
+ my $meth = "_pageset_" . $mode;
+ my $pred = "_has" . $meth;
+
+ ### use a cached version if possible
return $self->$meth if $self->$pred;
-
- my $pager = $self->___build_pageset( @_ );
-
+
+ my $pager = $self->_build_pageset( @_ );
+
### store the result
return $self->$meth( $pager );
}
-sub ___build_pageset {
- my $self = shift;
- my $struct = $self->content;
+sub _build_pageset {
+ my $self = shift;
+ my $struct = $self->content;
return unless exists $struct->{ response }->{ numFound };
- my $rows = $struct->{ responseHeader }->{ params }->{ rows };
- my $pager = Data::Pageset->new({
- total_entries => $struct->{ response }->{ numFound },
- entries_per_page => $rows || 10,
- current_page => do { $struct->{ response }->{ start } / $rows + 1 },
- pages_per_set => 10,
- mode => 'fixed', # default, or 'slide'
- @_,
- });
+ my $rows = $struct->{ responseHeader }->{ params }->{ rows };
+
+ # do not generate a pager for queries explicitly requesting no rows
+ return if defined $rows && $rows == 0;
+
+ # rows not explicitly set, find default from rows returned
+ if ( !defined $rows ) {
+ $rows = scalar @{ $struct->{ response }->{ docs } };
+ }
+
+ my $pager = Data::Pageset->new(
+ { total_entries => $struct->{ response }->{ numFound },
+ entries_per_page => $rows,
+ current_page => $struct->{ response }->{ start } / $rows + 1,
+ pages_per_set => 10,
+ mode => 'fixed', # default, or 'slide'
+ @_,
+ }
+ );
return $pager;
}
sub facet_counts {
- return shift->content->{ facet_counts };
+ return shift->content->{ facet_counts };
}
sub solr_status {
@@ -194,7 +213,7 @@
=head1 COPYRIGHT AND LICENSE
-Copyright 2008 National Adult Literacy Database
+Copyright 2008-2009 National Adult Literacy Database
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
Modified: branches/upstream/libwebservice-solr-perl/current/t/request/delete.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwebservice-solr-perl/current/t/request/delete.t?rev=48206&op=diff
==============================================================================
--- branches/upstream/libwebservice-solr-perl/current/t/request/delete.t (original)
+++ branches/upstream/libwebservice-solr-perl/current/t/request/delete.t Sat Dec 5 00:33:08 2009
@@ -1,7 +1,7 @@
use strict;
use warnings;
-use Test::More tests => 10;
+use Test::More tests => 18;
use Test::Mock::LWP;
use XML::Simple;
@@ -31,6 +31,16 @@
$solr->delete_by_query( 'name:DDR' );
}
+{
+ $expect = { query => 'foo', id => 13 };
+ $solr->delete( $expect );
+}
+
+{
+ $expect = { query => [ qw( foo bar ) ], id => [ 13, 42 ] };
+ $solr->delete( $expect );
+}
+
sub _test_req {
is( $_[ 2 ]->path, '/solr/update', 'delete() path' );
is_deeply( { $_[ 2 ]->query_form }, { wt => 'json' }, 'delete() params' );
Added: branches/upstream/libwebservice-solr-perl/current/t/request/rollback.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwebservice-solr-perl/current/t/request/rollback.t?rev=48206&op=file
==============================================================================
--- branches/upstream/libwebservice-solr-perl/current/t/request/rollback.t (added)
+++ branches/upstream/libwebservice-solr-perl/current/t/request/rollback.t Sat Dec 5 00:33:08 2009
@@ -1,0 +1,32 @@
+use strict;
+use warnings;
+
+use Test::More tests => 5;
+use Test::Mock::LWP;
+
+use XML::Simple;
+use HTTP::Headers;
+
+$Mock_ua->mock(
+ request => sub {
+ _test_req( @{ $_[ 1 ]->new_args } );
+ return HTTP::Response->new;
+ }
+);
+$Mock_response->mock( is_error => sub { return 0 } );
+
+use_ok( 'WebService::Solr' );
+my $solr = WebService::Solr->new;
+isa_ok( $solr, 'WebService::Solr' );
+$solr->rollback;
+
+sub _test_req {
+ is( $_[ 2 ]->path, '/solr/update', 'rollback() path' );
+ is(
+ $_[ 3 ]->header( 'Content_Type' ),
+ 'text/xml; charset=utf-8',
+ 'rollback() headers'
+ );
+ my $struct = XMLin( $_[ 4 ], KeepRoot => 1 );
+ is_deeply( $struct, { rollback => {} }, 'rollback() xml' );
+}
Modified: branches/upstream/libwebservice-solr-perl/current/t/response.t
URL: http://svn.debian.org/wsvn/pkg-perl/branches/upstream/libwebservice-solr-perl/current/t/response.t?rev=48206&op=diff
==============================================================================
--- branches/upstream/libwebservice-solr-perl/current/t/response.t (original)
+++ branches/upstream/libwebservice-solr-perl/current/t/response.t Sat Dec 5 00:33:08 2009
@@ -59,3 +59,16 @@
is( $pager->current_page, 3," Current page = 2" );
}
}
+
+### special case: 0 rows
+{
+ my $http_response = HTTP::Response->new(
+ 200 => 'OK',
+ HTTP::Headers->new,
+ q[{"responseHeader":{"status":0,"QTime":1,"params":{"facet.mincount":"1","q":"*:*","facet.field":"tags","wt":"json","rows":"0"}},"response":{"numFound":220,"start":0,"docs":[]}}],
+ );
+
+ my $solr_response = $Class->new( $http_response );
+ ok( !defined $solr_response->pager, '0 rows, undef pager' );
+ ok( !defined $solr_response->pageset, '0 rows, undef pageset' );
+}
More information about the Pkg-perl-cvs-commits
mailing list