r38934 - in /trunk/libwebservice-solr-perl: ./ debian/ inc/Module/ inc/Module/Install/ lib/WebService/ lib/WebService/Solr/ t/
jawnsy-guest at users.alioth.debian.org
jawnsy-guest at users.alioth.debian.org
Mon Jun 29 16:38:53 UTC 2009
Author: jawnsy-guest
Date: Mon Jun 29 16:38:47 2009
New Revision: 38934
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=38934
Log:
* New upstream release
+ Traps JSON::XS exceptions
+ New abstract query generator, WebService::Solr::Query
* Added /me to Uploaders and d/copyright
Added:
trunk/libwebservice-solr-perl/lib/WebService/Solr/Query.pm
trunk/libwebservice-solr-perl/t/query.t
Modified:
trunk/libwebservice-solr-perl/Changes
trunk/libwebservice-solr-perl/MANIFEST
trunk/libwebservice-solr-perl/META.yml
trunk/libwebservice-solr-perl/Makefile.PL
trunk/libwebservice-solr-perl/debian/changelog
trunk/libwebservice-solr-perl/debian/copyright
trunk/libwebservice-solr-perl/inc/Module/Install.pm
trunk/libwebservice-solr-perl/inc/Module/Install/Base.pm
trunk/libwebservice-solr-perl/inc/Module/Install/Can.pm
trunk/libwebservice-solr-perl/inc/Module/Install/Fetch.pm
trunk/libwebservice-solr-perl/inc/Module/Install/Makefile.pm
trunk/libwebservice-solr-perl/inc/Module/Install/Metadata.pm
trunk/libwebservice-solr-perl/inc/Module/Install/Win32.pm
trunk/libwebservice-solr-perl/inc/Module/Install/WriteAll.pm
trunk/libwebservice-solr-perl/lib/WebService/Solr.pm
trunk/libwebservice-solr-perl/lib/WebService/Solr/Response.pm
Modified: trunk/libwebservice-solr-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwebservice-solr-perl/Changes?rev=38934&op=diff
==============================================================================
--- trunk/libwebservice-solr-perl/Changes (original)
+++ trunk/libwebservice-solr-perl/Changes Mon Jun 29 16:38:47 2009
@@ -1,4 +1,9 @@
Revision history for Perl extension WebService::Solr.
+
+0.07 Fri Jun 26 2009
+ - Trap JSON::XS exceptions (Jos Boumans)
+ - Provide an abstract query generator: WebService::Solr::Query
+ (Jos Boumans, Brian Cassidy)
0.06 Thu May 07 2009
- Add auto_suggest to hit the new Solr 1.4 /autoSuggest API (RT #45798)
Modified: trunk/libwebservice-solr-perl/MANIFEST
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwebservice-solr-perl/MANIFEST?rev=38934&op=diff
==============================================================================
--- trunk/libwebservice-solr-perl/MANIFEST (original)
+++ trunk/libwebservice-solr-perl/MANIFEST Mon Jun 29 16:38:47 2009
@@ -10,6 +10,7 @@
lib/WebService/Solr.pm
lib/WebService/Solr/Document.pm
lib/WebService/Solr/Field.pm
+lib/WebService/Solr/Query.pm
lib/WebService/Solr/Response.pm
Makefile.PL
MANIFEST This list of files
@@ -20,6 +21,7 @@
t/live.t
t/pod.t
t/pod_coverage.t
+t/query.t
t/request/add.t
t/request/commit.t
t/request/delete.t
Modified: trunk/libwebservice-solr-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwebservice-solr-perl/META.yml?rev=38934&op=diff
==============================================================================
--- trunk/libwebservice-solr-perl/META.yml (original)
+++ trunk/libwebservice-solr-perl/META.yml Mon Jun 29 16:38:47 2009
@@ -10,7 +10,7 @@
configure_requires:
ExtUtils::MakeMaker: 6.42
distribution_type: module
-generated_by: 'Module::Install version 0.87'
+generated_by: 'Module::Install version 0.91'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -31,4 +31,4 @@
resources:
license: http://dev.perl.org/licenses/
repository: http://github.com/bricas/webservice-solr
-version: 0.06
+version: 0.07
Modified: trunk/libwebservice-solr-perl/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwebservice-solr-perl/Makefile.PL?rev=38934&op=diff
==============================================================================
--- trunk/libwebservice-solr-perl/Makefile.PL (original)
+++ trunk/libwebservice-solr-perl/Makefile.PL Mon Jun 29 16:38:47 2009
@@ -1,4 +1,4 @@
-use inc::Module::Install 0.87;
+use inc::Module::Install 0.91;
if( -e 'MANIFEST.SKIP' ) {
system( 'pod2text lib/WebService/Solr.pm > README' );
@@ -25,3 +25,4 @@
repository 'http://github.com/bricas/webservice-solr';
WriteAll;
+
Modified: trunk/libwebservice-solr-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwebservice-solr-perl/debian/changelog?rev=38934&op=diff
==============================================================================
--- trunk/libwebservice-solr-perl/debian/changelog (original)
+++ trunk/libwebservice-solr-perl/debian/changelog Mon Jun 29 16:38:47 2009
@@ -1,8 +1,14 @@
-libwebservice-solr-perl (0.06-2) UNRELEASED; urgency=low
+libwebservice-solr-perl (0.07-1) UNRELEASED; urgency=low
+ * New upstream release
+ + Traps JSON::XS exceptions
+ + New abstract query generator, WebService::Solr::Query
+ * Added /me to Uploaders and d/copyright
+
+ [ Nathan Handler ]
* debian/watch: Update to ignore development releases.
- -- Nathan Handler <nhandler at ubuntu.com> Sat, 06 Jun 2009 01:38:02 +0000
+ -- Jonathan Yu <frequency at cpan.org> Mon, 29 Jun 2009 08:34:45 -0400
libwebservice-solr-perl (0.06-1) unstable; urgency=low
Modified: trunk/libwebservice-solr-perl/debian/copyright
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwebservice-solr-perl/debian/copyright?rev=38934&op=diff
==============================================================================
--- trunk/libwebservice-solr-perl/debian/copyright (original)
+++ trunk/libwebservice-solr-perl/debian/copyright Mon Jun 29 16:38:47 2009
@@ -9,14 +9,16 @@
License-Alias: Perl
License: Artistic | GPL-1+
-Files: inc/*
-Copyright: Copyright 2002 - 2009 by Brian Ingerson, Audrey Tang and Adam Kennedy.
-License: GPL-1+ | Artistic
- This program is free software; you can redistribute it and/or modify it under
- the same terms as Perl itself.
+Files: inc/Module/*
+Copyright: 2002-2009, Adam Kennedy <adamk at cpan.org>
+ 2002-2009, Audrey Tang <autrijus at autrijus.org>
+ 2002-2009, Brian Ingerson <ingy at cpan.org>
+License-Alias: Perl
+License: Artistic | GPL-1+
Files: debian/*
-Copyright: 2008-2009 Brian Cassidy <brian.cassidy at gmail.com>
+Copyright: 2009, Jonathan Yu <frequency at cpan.org>
+ 2008-2009, Brian Cassidy <brian.cassidy at gmail.com>
License: Artistic | GPL-1+
License: Artistic
Modified: trunk/libwebservice-solr-perl/inc/Module/Install.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwebservice-solr-perl/inc/Module/Install.pm?rev=38934&op=diff
==============================================================================
--- trunk/libwebservice-solr-perl/inc/Module/Install.pm (original)
+++ trunk/libwebservice-solr-perl/inc/Module/Install.pm Mon Jun 29 16:38:47 2009
@@ -28,7 +28,7 @@
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
- $VERSION = '0.87';
+ $VERSION = '0.91';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -353,7 +353,7 @@
if ( $] >= 5.006 ) {
open( FH, '<', $_[0] ) or die "open($_[0]): $!";
} else {
- open( FH, "< $_[0]" ) or die "open($_[0]): $!";
+ open( FH, "< $_[0]" ) or die "open($_[0]): $!";
}
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
@@ -384,7 +384,7 @@
if ( $] >= 5.006 ) {
open( FH, '>', $_[0] ) or die "open($_[0]): $!";
} else {
- open( FH, "> $_[0]" ) or die "open($_[0]): $!";
+ open( FH, "> $_[0]" ) or die "open($_[0]): $!";
}
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
Modified: trunk/libwebservice-solr-perl/inc/Module/Install/Base.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwebservice-solr-perl/inc/Module/Install/Base.pm?rev=38934&op=diff
==============================================================================
--- trunk/libwebservice-solr-perl/inc/Module/Install/Base.pm (original)
+++ trunk/libwebservice-solr-perl/inc/Module/Install/Base.pm Mon Jun 29 16:38:47 2009
@@ -4,7 +4,7 @@
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '0.87';
+ $VERSION = '0.91';
}
# Suspend handler for "redefined" warnings
@@ -13,42 +13,34 @@
$SIG{__WARN__} = sub { $w };
}
-### This is the ONLY module that shouldn't have strict on
-# use strict;
-
-#line 45
+#line 42
sub new {
- my ($class, %args) = @_;
-
- foreach my $method ( qw(call load) ) {
- next if defined &{"$class\::$method"};
- *{"$class\::$method"} = sub {
- shift()->_top->$method(@_);
- };
+ my $class = shift;
+ unless ( defined &{"${class}::call"} ) {
+ *{"${class}::call"} = sub { shift->_top->call(@_) };
}
-
- bless( \%args, $class );
+ unless ( defined &{"${class}::load"} ) {
+ *{"${class}::load"} = sub { shift->_top->load(@_) };
+ }
+ bless { @_ }, $class;
}
-#line 66
+#line 61
sub AUTOLOAD {
- my $self = shift;
local $@;
- my $autoload = eval {
- $self->_top->autoload
- } or return;
- goto &$autoload;
+ my $func = eval { shift->_top->autoload } or return;
+ goto &$func;
}
-#line 83
+#line 75
sub _top {
$_[0]->{_top};
}
-#line 98
+#line 90
sub admin {
$_[0]->_top->{admin}
@@ -56,7 +48,7 @@
Module::Install::Base::FakeAdmin->new;
}
-#line 114
+#line 106
sub is_admin {
$_[0]->admin->VERSION;
@@ -83,4 +75,4 @@
1;
-#line 162
+#line 154
Modified: trunk/libwebservice-solr-perl/inc/Module/Install/Can.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwebservice-solr-perl/inc/Module/Install/Can.pm?rev=38934&op=diff
==============================================================================
--- trunk/libwebservice-solr-perl/inc/Module/Install/Can.pm (original)
+++ trunk/libwebservice-solr-perl/inc/Module/Install/Can.pm Mon Jun 29 16:38:47 2009
@@ -2,16 +2,16 @@
package Module::Install::Can;
use strict;
-use Module::Install::Base;
-use Config ();
-use File::Spec ();
-use ExtUtils::MakeMaker ();
+use Config ();
+use File::Spec ();
+use ExtUtils::MakeMaker ();
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.87';
+ $VERSION = '0.91';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
# check if we can load some module
Modified: trunk/libwebservice-solr-perl/inc/Module/Install/Fetch.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwebservice-solr-perl/inc/Module/Install/Fetch.pm?rev=38934&op=diff
==============================================================================
--- trunk/libwebservice-solr-perl/inc/Module/Install/Fetch.pm (original)
+++ trunk/libwebservice-solr-perl/inc/Module/Install/Fetch.pm Mon Jun 29 16:38:47 2009
@@ -2,13 +2,13 @@
package Module::Install::Fetch;
use strict;
-use Module::Install::Base;
+use Module::Install::Base ();
-use vars qw{$VERSION $ISCORE @ISA};
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.87';
+ $VERSION = '0.91';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
sub get_file {
Modified: trunk/libwebservice-solr-perl/inc/Module/Install/Makefile.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwebservice-solr-perl/inc/Module/Install/Makefile.pm?rev=38934&op=diff
==============================================================================
--- trunk/libwebservice-solr-perl/inc/Module/Install/Makefile.pm (original)
+++ trunk/libwebservice-solr-perl/inc/Module/Install/Makefile.pm Mon Jun 29 16:38:47 2009
@@ -2,14 +2,14 @@
package Module::Install::Makefile;
use strict 'vars';
-use Module::Install::Base;
-use ExtUtils::MakeMaker ();
-
-use vars qw{$VERSION $ISCORE @ISA};
+use ExtUtils::MakeMaker ();
+use Module::Install::Base ();
+
+use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.87';
+ $VERSION = '0.91';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
- @ISA = qw{Module::Install::Base};
}
sub Makefile { $_[0] }
Modified: trunk/libwebservice-solr-perl/inc/Module/Install/Metadata.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwebservice-solr-perl/inc/Module/Install/Metadata.pm?rev=38934&op=diff
==============================================================================
--- trunk/libwebservice-solr-perl/inc/Module/Install/Metadata.pm (original)
+++ trunk/libwebservice-solr-perl/inc/Module/Install/Metadata.pm Mon Jun 29 16:38:47 2009
@@ -2,18 +2,17 @@
package Module::Install::Metadata;
use strict 'vars';
-use Module::Install::Base;
+use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.87';
- @ISA = qw{Module::Install::Base};
+ $VERSION = '0.91';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
}
my @boolean_keys = qw{
sign
- mymeta
};
my @scalar_keys = qw{
@@ -440,21 +439,21 @@
/ixms ) {
my $license_text = $1;
my @phrases = (
- 'under the same (?:terms|license) as perl itself' => 'perl', 1,
- 'GNU general public license' => 'gpl', 1,
- 'GNU public license' => 'gpl', 1,
- 'GNU lesser general public license' => 'lgpl', 1,
- 'GNU lesser public license' => 'lgpl', 1,
- 'GNU library general public license' => 'lgpl', 1,
- 'GNU library public license' => 'lgpl', 1,
- 'BSD license' => 'bsd', 1,
- 'Artistic license' => 'artistic', 1,
- 'GPL' => 'gpl', 1,
- 'LGPL' => 'lgpl', 1,
- 'BSD' => 'bsd', 1,
- 'Artistic' => 'artistic', 1,
- 'MIT' => 'mit', 1,
- 'proprietary' => 'proprietary', 0,
+ 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1,
+ 'GNU general public license' => 'gpl', 1,
+ 'GNU public license' => 'gpl', 1,
+ 'GNU lesser general public license' => 'lgpl', 1,
+ 'GNU lesser public license' => 'lgpl', 1,
+ 'GNU library general public license' => 'lgpl', 1,
+ 'GNU library public license' => 'lgpl', 1,
+ 'BSD license' => 'bsd', 1,
+ 'Artistic license' => 'artistic', 1,
+ 'GPL' => 'gpl', 1,
+ 'LGPL' => 'lgpl', 1,
+ 'BSD' => 'bsd', 1,
+ 'Artistic' => 'artistic', 1,
+ 'MIT' => 'mit', 1,
+ 'proprietary' => 'proprietary', 0,
);
while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
$pattern =~ s{\s+}{\\s+}g;
@@ -506,17 +505,29 @@
}
}
+sub test_requires_from {
+ my $self = shift;
+ my $content = Module::Install::_readperl($_[0]);
+ my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg;
+ while ( @requires ) {
+ my $module = shift @requires;
+ my $version = shift @requires;
+ $self->test_requires( $module => $version );
+ }
+}
+
# Convert triple-part versions (eg, 5.6.1 or 5.8.9) to
# numbers (eg, 5.006001 or 5.008009).
# Also, convert double-part versions (eg, 5.8)
sub _perl_version {
my $v = $_[-1];
- $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
+ $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e;
$v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e;
$v =~ s/(\.\d\d\d)000$/$1/;
$v =~ s/_.+$//;
if ( ref($v) ) {
- $v = $v + 0; # Numify
+ # Numify
+ $v = $v + 0;
}
return $v;
}
@@ -526,21 +537,56 @@
######################################################################
-# MYMETA.yml Support
+# MYMETA Support
sub WriteMyMeta {
die "WriteMyMeta has been deprecated";
}
-sub write_mymeta {
- my $self = shift;
-
- # If there's no existing META.yml there is nothing we can do
- return unless -f 'META.yml';
+sub write_mymeta_yaml {
+ my $self = shift;
# We need YAML::Tiny to write the MYMETA.yml file
unless ( eval { require YAML::Tiny; 1; } ) {
return 1;
+ }
+
+ # Generate the data
+ my $meta = $self->_write_mymeta_data or return 1;
+
+ # Save as the MYMETA.yml file
+ print "Writing MYMETA.yml\n";
+ YAML::Tiny::DumpFile('MYMETA.yml', $meta);
+}
+
+sub write_mymeta_json {
+ my $self = shift;
+
+ # We need JSON to write the MYMETA.json file
+ unless ( eval { require JSON; 1; } ) {
+ return 1;
+ }
+
+ # Generate the data
+ my $meta = $self->_write_mymeta_data or return 1;
+
+ # Save as the MYMETA.yml file
+ print "Writing MYMETA.json\n";
+ Module::Install::_write(
+ 'MYMETA.json',
+ JSON->new->pretty(1)->canonical->encode($meta),
+ );
+}
+
+sub _write_mymeta_data {
+ my $self = shift;
+
+ # If there's no existing META.yml there is nothing we can do
+ return undef unless -f 'META.yml';
+
+ # We need Parse::CPAN::Meta to load the file
+ unless ( eval { require Parse::CPAN::Meta; 1; } ) {
+ return undef;
}
# Merge the perl version into the dependencies
@@ -558,7 +604,7 @@
}
# Load the advisory META.yml file
- my @yaml = YAML::Tiny::LoadFile('META.yml');
+ my @yaml = Parse::CPAN::Meta::LoadFile('META.yml');
my $meta = $yaml[0];
# Overwrite the non-configure dependency hashs
@@ -572,9 +618,7 @@
$meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } };
}
- # Save as the MYMETA.yml file
- print "Writing MYMETA.yml\n";
- YAML::Tiny::DumpFile('MYMETA.yml', $meta);
+ return $meta;
}
1;
Modified: trunk/libwebservice-solr-perl/inc/Module/Install/Win32.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwebservice-solr-perl/inc/Module/Install/Win32.pm?rev=38934&op=diff
==============================================================================
--- trunk/libwebservice-solr-perl/inc/Module/Install/Win32.pm (original)
+++ trunk/libwebservice-solr-perl/inc/Module/Install/Win32.pm Mon Jun 29 16:38:47 2009
@@ -2,12 +2,12 @@
package Module::Install::Win32;
use strict;
-use Module::Install::Base;
+use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.87';
- @ISA = qw{Module::Install::Base};
+ $VERSION = '0.91';
+ @ISA = 'Module::Install::Base';
$ISCORE = 1;
}
Modified: trunk/libwebservice-solr-perl/inc/Module/Install/WriteAll.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwebservice-solr-perl/inc/Module/Install/WriteAll.pm?rev=38934&op=diff
==============================================================================
--- trunk/libwebservice-solr-perl/inc/Module/Install/WriteAll.pm (original)
+++ trunk/libwebservice-solr-perl/inc/Module/Install/WriteAll.pm Mon Jun 29 16:38:47 2009
@@ -2,11 +2,11 @@
package Module::Install::WriteAll;
use strict;
-use Module::Install::Base;
+use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.87';
+ $VERSION = '0.91';;
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
@@ -41,8 +41,18 @@
# The Makefile write process adds a couple of dependencies,
# so write the META.yml files after the Makefile.
- $self->Meta->write if $args{meta};
- $self->Meta->write_mymeta if $self->mymeta;
+ if ( $args{meta} ) {
+ $self->Meta->write;
+ }
+
+ # Experimental support for MYMETA
+ if ( $ENV{X_MYMETA} ) {
+ if ( $ENV{X_MYMETA} eq 'JSON' ) {
+ $self->Meta->write_mymeta_json;
+ } else {
+ $self->Meta->write_mymeta_yaml;
+ }
+ }
return 1;
}
Modified: trunk/libwebservice-solr-perl/lib/WebService/Solr.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwebservice-solr-perl/lib/WebService/Solr.pm?rev=38934&op=diff
==============================================================================
--- trunk/libwebservice-solr-perl/lib/WebService/Solr.pm (original)
+++ trunk/libwebservice-solr-perl/lib/WebService/Solr.pm Mon Jun 29 16:38:47 2009
@@ -28,7 +28,7 @@
default => sub { { wt => 'json' } }
);
-our $VERSION = '0.06';
+our $VERSION = '0.07';
sub BUILDARGS {
my ( $self, $url, $options ) = @_;
Added: trunk/libwebservice-solr-perl/lib/WebService/Solr/Query.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwebservice-solr-perl/lib/WebService/Solr/Query.pm?rev=38934&op=file
==============================================================================
--- trunk/libwebservice-solr-perl/lib/WebService/Solr/Query.pm (added)
+++ trunk/libwebservice-solr-perl/lib/WebService/Solr/Query.pm Mon Jun 29 16:38:47 2009
@@ -1,0 +1,429 @@
+package WebService::Solr::Query;
+
+use Moose;
+
+use overload q("") => 'stringify';
+
+my $escape_chars = quotemeta( '+-&|!(){}[]^"~*?:\\' );
+
+has 'query' => ( is => 'ro', isa => 'ArrayRef', default => sub { [] } );
+
+use constant D => 0;
+use Data::Dumper;
+
+sub BUILDARGS {
+ my $class = shift;
+
+ if ( @_ == 1 && ref $_[ 0 ] && ref $_[ 0 ] eq 'ARRAY' ) {
+ return { query => $_[ 0 ] };
+ }
+
+ return { query => \@_ };
+}
+
+sub stringify {
+ my $self = shift;
+
+ return $self->_dispatch_struct( $self->query );
+}
+
+sub _dispatch_struct {
+ my ( $self, $struct ) = @_;
+
+ my $method = '_struct_' . ref $struct;
+
+ D && $self->___log( "Dispatching to ->$method ". Dumper $struct );
+
+ my $rv = $self->$method( $struct );
+
+ D && $self->___log( "Returned: $rv" );
+
+ return $rv;
+}
+
+sub _struct_HASH {
+ my ( $self, $struct ) = @_;
+
+ my @clauses;
+
+ for my $k ( keys %$struct ) {
+ my $v = $struct->{ $k };
+
+ D && $self->___log("Key => $k, value => ". Dumper($v));
+
+ if ( $k =~ m{^-(.+)} ) {
+ my $method = "_op_$1";
+
+ D && $self->___log("Dispatch ->$method ". Dumper($v));
+ push @clauses, $self->$method( $v );
+ }
+ else {
+ 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");
+
+ return $rv;
+}
+
+sub _struct_ARRAY {
+ my ( $self, $struct ) = @_;
+
+ my $rv =
+ '('
+ . join( " OR ", map { $self->_dispatch_struct( $_ ) } @$struct )
+ . ')';
+
+ D && $self->___log("Returning: $rv");
+
+ return $rv;
+}
+
+sub _dispatch_value {
+ my ( $self, $k, $v ) = @_;
+
+ my $rv;
+ ### it's an array ref, the first element MAY be an operator!
+ ### it would look something like this:
+ # [ '-and',
+ # { '-require' => 'star' },
+ # { '-require' => 'wars' }
+ # ];
+ 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));
+
+ my @clauses;
+ for my $href ( @$v ) {
+ 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 .')';
+ }
+
+ $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));
+
+ $rv = $self->$method( $k, $v );
+ }
+
+ D && $self->___log("Returning: $rv");
+
+ return $rv;
+}
+
+sub _value_SCALAR {
+ my ( $self, $k, $v ) = @_;
+ $v = $self->escape( $v );
+ my $r = qq($k:"$v");
+ $r =~ s{^:}{};
+
+ D && $self->___log("Returning: $r");
+
+ return $r;
+}
+
+sub _value_HASH {
+ my ( $self, $k, $v ) = @_;
+
+ my @clauses;
+
+ for my $op ( keys %$v ) {
+ my $struct = $v->{ $op };
+ $op =~ s{^-(.+)}{_op_$1};
+
+ D && $self->___log("Dispatch ->$op $k, ". Dumper($v));
+
+ push @clauses, $self->$op( $k, $struct );
+ }
+
+ my $rv = join( ' AND ', @clauses );
+
+ D && $self->___log("Returning: $rv");
+
+ return $rv;
+}
+
+sub _value_ARRAY {
+ my ( $self, $k, $v ) = @_;
+
+ my $rv =
+ '('
+ . join( ' OR ', map { $self->_value_SCALAR( $k, $_ ) } @$v ) . ')';
+
+ D && $self->___log("Returning: $rv");
+
+ return $rv;
+}
+
+sub _op_default {
+ my ( $self, $v ) = @_;
+ return $self->_dispatch_value( '', $v );
+}
+
+sub _op_range {
+ my ( $self, $k ) = ( shift, shift );
+ my @v = @{ shift() };
+ return "$k:[$v[ 0 ] TO $v[ 1 ]]";
+}
+
+*_op_range_inc = \&_op_range;
+
+sub _op_range_exc {
+ my ( $self, $k ) = ( shift, shift );
+ my @v = @{ shift() };
+ return "$k:{$v[ 0 ] TO $v[ 1 ]}";
+}
+
+sub _op_boost {
+ my ( $self, $k ) = ( shift, shift );
+ my ( $v, $boost ) = @{ shift() };
+ $v = $self->escape( $v );
+ return qq($k:"$v"^$boost);
+}
+
+sub _op_fuzzy {
+ my ( $self, $k ) = ( shift, shift );
+ my ( $v, $distance ) = @{ shift() };
+ $v = $self->escape( $v );
+ return qq($k:$v~$distance);
+}
+
+sub _op_proximity {
+ my ( $self, $k ) = ( shift, shift );
+ my ( $v, $distance ) = @{ shift() };
+ $v = $self->escape( $v );
+ return qq($k:"$v"~$distance);
+}
+
+sub _op_require {
+ my ( $self, $k, $v ) = @_;
+ $v = $self->escape( $v );
+ return qq(+$k:"$v");
+}
+
+sub _op_prohibit {
+ my ( $self, $k, $v ) = @_;
+ $v = $self->escape( $v );
+ return qq(-$k:"$v");
+}
+
+sub escape {
+ my ( $self, $text ) = @_;
+ $text =~ s{([$escape_chars])}{\\$1}g;
+ return $text;
+}
+
+sub unescape {
+ my ( $self, $text ) = @_;
+ $text =~ s{\\([$escape_chars])}{$1}g;
+ return $text;
+}
+
+sub ___log {
+ my $self = shift;
+ my $msg = shift;
+
+ ### 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];
+
+ ### make sure we prefix every line with a #
+ $msg =~ s/\n/\n#/g;
+
+ print "# $who: $msg\n";
+}
+
+no Moose;
+
+__PACKAGE__->meta->make_immutable;
+
+1;
+
+__END__
+
+=head1 NAME
+
+WebService::Solr::Query - Abstract query syntax for Solr queries
+
+=head1 SYNOPSIS
+
+ my $query = WebService::Solr::Query->new( { foo => 'bar' } );
+ my $result = $solr->search( $query );
+
+=head1 DESCRIPTION
+
+WebService::Solr::Query provides a programmatic way to generate
+queries to be sent to Solr. Syntax wise, it attempts to be as close to
+L<SQL::Abstract> WHERE clauses as possible, with obvious exceptions for
+idioms that do not exist in SQL. Just as values in SQL::Abstract are
+SQL-escaped, this module does the appropriate Solr-escaping on all values
+passed to the object (see C<escape()>).
+
+=head1 QUERY SYNTAX
+
+=head2 Key-Value Pairs
+
+The simplest way to search is with key value pairs.
+
+ my $q = WebService::Solr::Query->new( { foo => 'bar' } );
+ # RESULT: (foo:"bar")
+
+=head2 Implicit AND and OR
+
+By default, data received as a HASHREF is AND'ed together.
+
+ my $q = WebService::Solr::Query->new( { foo => 'bar', baz => 'quux' } );
+ # RESULT: (foo:"bar" AND baz:"quux")
+
+Furthermore, data received as an ARRAYREF is OR'ed together.
+
+ my $q = WebService::Solr::Query->new( { foo => [ 'bar', 'baz' ] } );
+ # RESULT: (foo:"bar" OR foo:"baz")
+
+=head2 Nested AND and OR
+
+The ability to nest AND and OR boolean operators is essential to express
+complex queries. The C<-and> and C<-or> prefixes have been provided for this
+need.
+
+ my $q = WebService::Solr::Query->new( foo => [
+ -and => { -prohibit => 'bar' }, { -require => 'baz' }
+ ] );
+ # RESULT: (((-foo:"bar") AND (+foo:"baz")))
+
+ my $q = WebService::Solr::Query->new( foo => [
+ -or => { -require => 'bar' }, { -prohibit => 'baz' }
+ ] );
+ # RESULT: (((+foo:"bar") OR (-foo:"baz")))
+
+=head2 Default Field
+
+To search the default field, use the C<-default> prefix.
+
+ my $q = WebService::Solr::Query->new( { -default => 'bar' } );
+ # RESULT: ("bar")
+
+=head2 Require/Prohibit
+
+ my $q = WebService::Solr::Query->new( foo => { -require => 'bar' } );
+ # RESULT: (+foo:"bar")
+
+ my $q = WebService::Solr::Query->new( foo => { -prohibit => 'bar' } );
+ # RESULT: (-foo:"bar")
+
+=head2 Range
+
+There are two types of range queries, inclusive (C<-range_inc>) and
+exclusive (C<-range_exc>). The C<-range> prefix can be used in place of
+C<-range_inc>.
+
+ my $q = WebService::Solr::Query->new( foo => { -range => ['a', 'z'] } );
+ # RESULT: (+foo:[a TO z])
+
+ my $q = WebService::Solr::Query->new( foo => { -range_exc => ['a', 'z'] } );
+ # RESULT: (+foo:{a TO z})
+
+=head2 Boost
+
+ my $q = WebService::Solr::Query->new( foo => { -boost => [ 'bar', '2.0' ] } );
+ # RESULT: (foo:"bar"^2.0)
+
+=head2 Proximity
+
+ my $q = WebService::Solr::Query->new( foo => { -proximity => [ 'bar baz', 10 ] } );
+ # RESULT: (foo:"bar baz"~10)
+
+=head2 Fuzzy
+
+ my $q = WebService::Solr::Query->new( foo => { -fuzzy => [ 'bar', '0.8' ] } );
+ # RESULT: (foo:bar~0.8)
+
+=head2 Boost
+
+ my $q = WebService::Solr::Query->new( foo => { -boost => [ 'bar', '2.0' ] } );
+ # RESULT: (foo:"bar"^2.0)
+
+=head1 ACCESSORS
+
+=over 4
+
+=item * query - stores the original query structure
+
+=back
+
+=head1 METHODS
+
+=head2 new( \%query )
+
+Creates a new query object with the given hashref.
+
+=head2 stringify( )
+
+Converts the supplied structure into a Solr/Lucene query.
+
+=head2 escape( $value )
+
+The following values must be escaped in a search value:
+
+ + - & | ! ( ) { } [ ] ^ " ~ * ? : \
+
+B<NB:> Values sent to C<new()> are automatically escaped for you.
+
+=head2 unescape( $value )
+
+Unescapes values escaped in C<escape()>.
+
+=head2 D
+
+Debugging constant, default: off.
+
+=head2 BUILDARGS
+
+Moose method to handle input to C<new()>.
+
+=head1 SEE ALSO
+
+=over 4
+
+=item * L<WebService::Solr>
+
+=item * http://wiki.apache.org/solr/SolrQuerySyntax
+
+=back
+
+=head1 AUTHORS
+
+Brian Cassidy E<lt>bricas at cpan.orgE<gt>
+
+Jos Boumans E<lt>kane at cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+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.
+
+=cut
Modified: trunk/libwebservice-solr-perl/lib/WebService/Solr/Response.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwebservice-solr-perl/lib/WebService/Solr/Response.pm?rev=38934&op=diff
==============================================================================
--- trunk/libwebservice-solr-perl/lib/WebService/Solr/Response.pm (original)
+++ trunk/libwebservice-solr-perl/lib/WebService/Solr/Response.pm Mon Jun 29 16:38:47 2009
@@ -28,7 +28,13 @@
my $self = shift;
my $content = $self->raw_response->content;
return {} unless $content;
- return JSON::XS::decode_json( $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;
}
sub _build_docs {
Added: trunk/libwebservice-solr-perl/t/query.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libwebservice-solr-perl/t/query.t?rev=38934&op=file
==============================================================================
--- trunk/libwebservice-solr-perl/t/query.t (added)
+++ trunk/libwebservice-solr-perl/t/query.t Mon Jun 29 16:38:47 2009
@@ -1,0 +1,204 @@
+use Test::More 'no_plan';
+
+use strict;
+use warnings;
+
+BEGIN {
+ use_ok( 'WebService::Solr::Query' );
+}
+
+{ # (un)escape
+ is( WebService::Solr::Query->escape( '(1+1):2' ),
+ '\(1\+1\)\:2', 'escape' );
+ is( WebService::Solr::Query->unescape( '\(1\+1\)\:2' ),
+ '(1+1):2', 'unescape' );
+}
+
+{ # basic queries
+ # default field
+ _check( query => { -default => 'space' }, expect => '("space")' );
+ _check(
+ query => { -default => [ 'star trek', 'star wars' ] },
+ expect => '(("star trek" OR "star wars"))'
+ );
+
+ # field
+ _check(
+ query => { title => 'Spaceballs' },
+ expect => '(title:"Spaceballs")'
+ );
+ _check(
+ query => { first => 'Roger', last => 'Moore' },
+ expect => '(first:"Roger" AND last:"Moore")'
+ );
+ _check(
+ query => { first => [ 'Roger', 'Dodger' ] },
+ expect => '((first:"Roger" OR first:"Dodger"))'
+ );
+ _check(
+ query => { first => [ 'Roger', 'Dodger' ], last => 'Moore' },
+ expect => '((first:"Roger" OR first:"Dodger") AND last:"Moore")'
+ );
+ _check(
+ query => [ { first => [ 'Roger', 'Dodger' ] }, { last => 'Moore' } ],
+ expect => '((first:"Roger" OR first:"Dodger") OR last:"Moore")'
+ );
+
+ _check(
+ query => {
+ first => [ 'Roger', 'Dodger' ],
+ -default => [ 'star trek', 'star wars' ]
+ },
+ expect =>
+ '(("star trek" OR "star wars") AND (first:"Roger" OR first:"Dodger"))'
+ );
+}
+
+{ # basic query with escape
+ _check( query => { -default => 'sp(a)ce' }, expect => '("sp\(a\)ce")' );
+ _check(
+ query => { title => 'Spaceb(a)lls' },
+ expect => '(title:"Spaceb\(a\)lls")'
+ );
+}
+
+{ # simple ops
+ # range (inc)
+ _check(
+ query => { title => { -range => [ 'a', 'z' ] } },
+ expect => '(title:[a TO z])'
+ );
+ _check(
+ query => {
+ first => [ 'Roger', 'Dodger' ],
+ title => { -range => [ 'a', 'z' ] }
+ },
+ expect => '((first:"Roger" OR first:"Dodger") AND title:[a TO z])'
+ );
+
+ # range (exc)
+ _check(
+ query => { title => { -range_exc => [ 'a', 'z' ] } },
+ expect => '(title:{a TO z})'
+ );
+ _check(
+ query => {
+ first => [ 'Roger', 'Dodger' ],
+ title => { -range_exc => [ 'a', 'z' ] }
+ },
+ expect => '((first:"Roger" OR first:"Dodger") AND title:{a TO z})'
+ );
+
+ # boost
+ _check(
+ query => { title => { -boost => [ 'Space', '2.0' ] } },
+ expect => '(title:"Space"^2.0)'
+ );
+ _check(
+ query => {
+ first => [ 'Roger', 'Dodger' ],
+ title => { -boost => [ 'Space', '2.0' ] }
+ },
+ expect => '((first:"Roger" OR first:"Dodger") AND title:"Space"^2.0)'
+ );
+
+ # proximity
+ _check(
+ query => { title => { -proximity => [ 'space balls', '10' ] } },
+ expect => '(title:"space balls"~10)'
+ );
+ _check(
+ query => {
+ first => [ 'Roger', 'Dodger' ],
+ title => { -proximity => [ 'space balls', '10' ] }
+ },
+ expect =>
+ '((first:"Roger" OR first:"Dodger") AND title:"space balls"~10)'
+ );
+
+ # fuzzy
+ _check(
+ query => { title => { -fuzzy => [ 'space', '0.8' ] } },
+ expect => '(title:space~0.8)'
+ );
+ _check(
+ query => {
+ first => [ 'Roger', 'Dodger' ],
+ title => { -fuzzy => [ 'space', '0.8' ] }
+ },
+ expect => '((first:"Roger" OR first:"Dodger") AND title:space~0.8)'
+ );
+
+}
+
+{ # ops with escape
+ _check(
+ query => { title => { -boost => [ 'Sp(a)ce', '2.0' ] } },
+ expect => '(title:"Sp\(a\)ce"^2.0)'
+ );
+ _check(
+ query => { title => { -proximity => [ 'sp(a)ce balls', '10' ] } },
+ expect => '(title:"sp\(a\)ce balls"~10)'
+ );
+ _check(
+ query => { title => { -fuzzy => [ 'sp(a)ce', '0.8' ] } },
+ expect => '(title:sp\(a\)ce~0.8)'
+ );
+}
+
+{ # require and prohibit
+ _check(
+ query => { title => { -require => 'star' } },
+ expect => '(+title:"star")'
+ );
+ _check(
+ query => {
+ first => [ 'Roger', 'Dodger' ],
+ title => { -require => 'star' }
+ },
+ expect => '((first:"Roger" OR first:"Dodger") AND +title:"star")'
+ );
+
+ _check(
+ query => { title => { -prohibit => 'star' } },
+ expect => '(-title:"star")'
+ );
+ _check(
+ query => { default => { -prohibit => 'foo' } },
+ expect => '(-default:"foo")'
+ );
+
+ _check(
+ query => {
+ first => [ 'Roger', 'Dodger' ],
+ title => { -prohibit => 'star' }
+ },
+ expect => '((first:"Roger" OR first:"Dodger") AND -title:"star")'
+ );
+}
+
+### nested and/or operators
+{ _check(
+ query => {
+ title => [ -and => { -require => 'star' }, { -require => 'wars' } ],
+ },
+ expect => q[(((+title:"star") AND (+title:"wars")))],
+ );
+
+ _check(
+ query => {
+ title => [ -or => { -range_exc => [ 'a', 'c' ] },
+ { -range_exc => [ 'e', 'k' ] } ],
+ },
+ expect => q[(((title:{a TO c}) OR (title:{e TO k})))],
+ );
+
+
+}
+sub _check {
+ my %t = @_;
+
+ my $q = WebService::Solr::Query->new( $t{ query } );
+ isa_ok( $q, 'WebService::Solr::Query' );
+ is( $q->stringify, $t{ expect }, $t{ expect } );
+}
More information about the Pkg-perl-cvs-commits
mailing list