WebService-Solr-0.22/0000755000101700007640000000000012126653250013571 5ustar alesterispcWebService-Solr-0.22/lib/0000755000101700007640000000000012126653250014337 5ustar alesterispcWebService-Solr-0.22/lib/WebService/0000755000101700007640000000000012126653250016375 5ustar alesterispcWebService-Solr-0.22/lib/WebService/Solr.pm0000644000101700007640000002444712126652474017674 0ustar alesterispcpackage WebService::Solr; use Any::Moose; use Encode qw(encode); use URI; use LWP::UserAgent; use WebService::Solr::Response; use HTTP::Request; use HTTP::Headers; use XML::Easy::Element; use XML::Easy::Content; use XML::Easy::Text (); has 'url' => ( is => 'ro', isa => 'URI', default => sub { URI->new( 'http://localhost:8983/solr' ) } ); has 'agent' => ( is => 'ro', isa => 'Object', default => sub { LWP::UserAgent->new } ); has 'autocommit' => ( is => 'ro', isa => 'Bool', default => 1 ); has 'default_params' => ( is => 'ro', isa => 'HashRef', auto_deref => 1, default => sub { { wt => 'json' } } ); has 'last_response' => ( is => 'rw', isa => 'Maybe[WebService::Solr::Response]', ); our $VERSION = '0.22'; sub BUILDARGS { my ( $self, $url, $options ) = @_; $options ||= {}; if ( $url ) { $options->{ url } = ref $url ? $url : URI->new( $url ); } if ( exists $options->{ default_params } ) { $options->{ default_params } = { %{ $options->{ default_params } }, wt => 'json', }; } return $options; } sub add { my ( $self, $doc, $params ) = @_; my @docs = ref $doc eq 'ARRAY' ? @$doc : ( $doc ); my @elements = map { ( '', blessed $_ ? $_->to_element : WebService::Solr::Document->new( ref $_ eq 'HASH' ? %$_ : @$_ )->to_element ) } @docs; $params ||= {}; my $e = XML::Easy::Element->new( 'add', $params, XML::Easy::Content->new( [ @elements, '' ] ), ); my $xml = XML::Easy::Text::xml10_write_element( $e ); my $response = $self->_send_update( $xml ); return $response->ok; } sub update { return shift->add( @_ ); } sub commit { my ( $self, $params ) = @_; $params ||= {}; my $e = XML::Easy::Element->new( 'commit', $params, [ '' ] ); my $xml = XML::Easy::Text::xml10_write_element( $e ); my $response = $self->_send_update( $xml, {}, 0 ); return $response->ok; } sub rollback { my ( $self ) = @_; my $response = $self->_send_update( '', {}, 0 ); return $response->ok; } sub optimize { my ( $self, $params ) = @_; $params ||= {}; my $e = XML::Easy::Element->new( 'optimize', $params, [ '' ] ); my $xml = XML::Easy::Text::xml10_write_element( $e ); my $response = $self->_send_update( $xml, {}, 0 ); return $response->ok; } sub delete { my ( $self, $options ) = @_; my $xml = ''; for my $k ( keys %$options ) { my $v = $options->{ $k }; $xml .= join( '', map { XML::Easy::Text::xml10_write_element( XML::Easy::Element->new( $k, {}, [ $_ ] ) ) } ref $v ? @$v : $v ); } my $response = $self->_send_update( "${xml}" ); return $response->ok; } sub delete_by_id { my ( $self, $id ) = @_; return $self->delete( { id => $id } ); } sub delete_by_query { my ( $self, $query ) = @_; return $self->delete( { query => $query } ); } sub ping { my ( $self ) = @_; $self->last_response( WebService::Solr::Response->new( $self->agent->get( $self->_gen_url( 'admin/ping' ) ) ) ); return $self->last_response->is_success; } sub search { my ( $self, $query, $params ) = @_; $params ||= {}; $params->{ 'q' } = $query; return $self->generic_solr_request( 'select', $params ); } sub auto_suggest { shift->generic_solr_request( 'autoSuggest', @_ ); } sub generic_solr_request { my ( $self, $path, $params ) = @_; $params ||= {}; return $self->last_response( WebService::Solr::Response->new( $self->agent->post( $self->_gen_url( $path ), Content_Type => 'application/x-www-form-urlencoded; charset=utf-8', Content => { $self->default_params, %$params } ) ) ); } sub _gen_url { my ( $self, $handler ) = @_; my $url = $self->url->clone; $url->path( $url->path . "/$handler" ); return $url; } sub _send_update { my ( $self, $xml, $params, $autocommit ) = @_; $autocommit = $self->autocommit unless defined $autocommit; $params ||= {}; my $url = $self->_gen_url( 'update' ); $url->query_form( { $self->default_params, %$params } ); my $req = HTTP::Request->new( POST => $url, HTTP::Headers->new( Content_Type => 'text/xml; charset=utf-8' ), '' . encode( 'utf8', "$xml" ) ); my $http_response = $self->agent->request( $req ); if ( $http_response->is_error ) { confess $http_response->status_line . ': ' . $http_response->content; } $self->last_response( WebService::Solr::Response->new( $http_response ) ); $self->commit if $autocommit; return $self->last_response; } no Any::Moose; __PACKAGE__->meta->make_immutable; 1; __END__ =head1 NAME WebService::Solr - Module to interface with the Solr (Lucene) webservice =head1 SYNOPSIS my $solr = WebService::Solr->new; $solr->add( @docs ); my $response = $solr->search( $query ); for my $doc ( $response->docs ) { print $doc->value_for( $id ); } =head1 DESCRIPTION WebService::Solr is a client library for Apache Lucene's Solr; an enterprise-grade indexing and searching platform. =head1 ACCESSORS =over 4 =item * url - the webservice base url =item * agent - a user agent object =item * autocommit - a boolean value for automatic commit() after add/update/delete (default: enabled) =item * default_params - a hashref of parameters to send on every request =item * last_response - stores a WebService::Solr::Response for the last request =back =head1 HTTP KEEP-ALIVE Enabling HTTP Keep-Alive is as simple as passing your custom user-agent to the constructor. my $solr = WebService::Solr->new( $url, { agent => LWP::UserAgent->new( keep_alive => 1 ) } ); Visit L's documentation for more information and available options. =head1 METHODS =head2 new( $url, \%options ) Creates a new WebService::Solr instance. If C<$url> is omitted, then C is used as a default. Available options are listed in the L section. =head2 BUILDARGS( @args ) A Moose override to allow our custom constructor. =head2 add( $doc|\@docs, \%options ) Adds a number of documents to the index. Returns true on success, false otherwise. A document can be a L object or a structure that can be passed to Cnew>. Available options as of Solr 1.4 are: =over 4 =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. =head2 delete( \%options ) Deletes documents matching the options provided. The delete operation currently accepts C and C 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 ) Deletes all documents matching the id specified. Returns true on success, false otherwise. =head2 delete_by_query( $query ) Deletes documents matching C<$query>. Returns true on success, false otherwise. =head2 search( $query, \%options ) Searches the index given a C<$query>. Returns a L object. All key-value pairs supplied in C<\%options> are serialzied in the request URL. If filter queries are needed, create WebService::Solr::Query objects and pass them into the C<%options>. For example, if you were searching a database of books for a subject of "Perl", but wanted only paperbacks and a copyright year of 2011 or 2012: my $query = WebService::Solr::Query->new( { subject => 'Perl' } ); my %options = ( fq => [ WebService::Solr::Query->new( { binding => 'Paperback' } ), WebService::Solr::Query->new( { year => [ 2011, 2012 ] } ), ], ); my $response = $solr->search( $query, \%options ); The filter queries are typically added when drilling down into search results and selecting a facet to drill into. =head2 auto_suggest( \%options ) Get suggestions from a list of terms for a given field. The Solr wiki has more details about the available options (http://wiki.apache.org/solr/TermsComponent) =head2 commit( \%options ) Sends a commit command. Returns true on success, false otherwise. You must do a commit after an add, update or delete. By default, autocommit is enabled. You may disable autocommit to allow you to issue commit commands manually: my $solr = WebService::Solr->new( undef, { autocommit => 0 } ); $solr->add( $doc ); # will not automatically call commit() $solr->commit; Options as of Solr 1.4 include: =over 4 =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.4 are the same as C. =head2 ping( ) Sends a basic ping request. Returns true on success, false otherwise. =head2 generic_solr_request( $path, \%query ) Performs a simple C request appending C<$path> to the base URL and using key-value pairs from C<\%query> to generate the query string. This should allow you to access parts of the Solr API that don't yet have their own correspodingly named function (e.g. C ). =head1 SEE ALSO =over 4 =item * http://lucene.apache.org/solr/ =item * L - an alternate library =back =head1 AUTHORS Brian Cassidy Ebricas@cpan.orgE Kirk Beers =head1 COPYRIGHT AND LICENSE Copyright 2008-2013 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 WebService-Solr-0.22/lib/WebService/Solr/0000755000101700007640000000000012126653250017314 5ustar alesterispcWebService-Solr-0.22/lib/WebService/Solr/Response.pm0000644000101700007640000001217712115143471021455 0ustar alesterispcpackage WebService::Solr::Response; use Any::Moose; use WebService::Solr::Document; use Data::Page; use Data::Pageset; use JSON::XS (); has 'raw_response' => ( is => 'ro', isa => 'Object', handles => { status_code => 'code', status_message => 'message', is_success => 'is_success', is_error => 'is_error' }, ); has 'content' => ( is => 'rw', isa => 'HashRef', lazy_build => 1 ); has 'docs' => ( is => 'rw', isa => 'ArrayRef', auto_deref => 1, 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 ) = @_; return { raw_response => $res }; } sub _build_content { 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; } sub _build_docs { my $self = shift; my $struct = $self->content; return unless exists $struct->{ response }->{ docs }; return [ map { WebService::Solr::Document->new( %$_ ) } @{ $struct->{ response }->{ docs } } ]; } sub _build_pager { my $self = shift; my $struct = $self->content; return unless exists $struct->{ response }->{ numFound }; my $rows = $struct->{ responseHeader }->{ params }->{ rows }; $rows = 10 unless defined $rows; # do not generate a pager for queries explicitly requesting no rows return if $rows == 0; my $pager = Data::Page->new; $pager->total_entries( $struct->{ response }->{ numFound } ); $pager->entries_per_page( $rows ); $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 possible return $self->$meth if $self->$pred; my $pager = $self->_build_pageset( @_ ); ### store the result return $self->$meth( $pager ); } sub _build_pageset { my $self = shift; my $struct = $self->content; return unless exists $struct->{ response }->{ numFound }; my $rows = $struct->{ responseHeader }->{ params }->{ rows }; $rows = 10 unless defined $rows; # do not generate a pager for queries explicitly requesting no rows return if $rows == 0; 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 }; } sub spellcheck { return shift->content->{ spellcheck }; } sub solr_status { return shift->content->{ responseHeader }->{ status }; } sub ok { my $status = shift->solr_status; return defined $status && $status == 0; } no Any::Moose; __PACKAGE__->meta->make_immutable; 1; __END__ =head1 NAME WebService::Solr::Response - Parse responses from Solr =head1 SYNOPSIS my $res = WebService::Solr::Response->new( $http_res ); for my $doc( $res->docs ) { print $doc->value_for( 'id'), "\n"; } my $pager = $res->pager; =head1 DESCRIPTION This class encapsulates responses from the Solr Web Service. Typically it is used when documents are returned from a search query, though it will accept all responses from the service. =head1 ACCESSORS =over 4 =item * raw_response - the raw L object. =item * content - a hashref of deserialized JSON data from the response. =item * docs - an array of L objects. =item * pager - a L object for the search results. =item * pageset - a L object for the search results. Takes the same arguments as C<< Data::Pageset->new >> does. All arguments optional. =back =head1 METHODS =head2 new( $response ) Given an L object, it will parse the returned data as required. =head2 BUILDARGS( @args ) A Moose override to allow our custom constructor. =head2 facet_counts( ) A shortcut to the C key in the response data. =head2 spellcheck( ) A shortcut to the C key in the response data. =head2 solr_status( ) Looks for the status value in the response data. =head2 ok( ) Calls C and check that it is equal to 0. =head1 AUTHORS Brian Cassidy Ebricas@cpan.orgE Kirk Beers =head1 COPYRIGHT AND LICENSE Copyright 2008-2013 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 WebService-Solr-0.22/lib/WebService/Solr/Document.pm0000644000101700007640000000701112115143471021424 0ustar alesterispcpackage WebService::Solr::Document; use WebService::Solr::Field; use XML::Easy::Element; use XML::Easy::Content; use XML::Easy::Text (); use Scalar::Util 'blessed'; sub new { my ( $class, @fields ) = @_; my $self = { fields => [ _parse_fields( @fields ) ] }; return bless $self, $class; } sub boost { my $self = shift; $self->{ boost } = $_[ 0 ] if @_; return $self->{ boost }; } sub fields { my $self = shift; $self->{ fields } = $_[ 0 ] if @_; return wantarray ? @{ $self->{ fields } } : $self->{ fields }; } sub add_fields { my ( $self, @fields ) = @_; $self->fields( [ $self->fields, _parse_fields( @fields ) ] ); } sub _parse_fields { my @fields = @_; my @new_fields; # handle field objects, array refs and normal k => v pairs while ( my $f = shift @fields ) { if ( blessed $f ) { push @new_fields, $f; next; } elsif ( ref $f ) { push @new_fields, WebService::Solr::Field->new( @$f ); next; } my $v = shift @fields; my @values = ( ref $v and !blessed $v ) ? @$v : $v; push @new_fields, map { WebService::Solr::Field->new( $f => "$_" ) } @values; } return @new_fields; } sub field_names { my ( $self ) = @_; my %names = map { $_->name => 1 } $self->fields; return keys %names; } sub value_for { my ( $self, $key ) = @_; for my $field ( $self->fields ) { if ( $field->name eq $key ) { return $field->value; } } return; } sub values_for { my ( $self, $key ) = @_; return map { $_->value } grep { $_->name eq $key } $self->fields; } sub to_element { my $self = shift; my %attr = ( $self->boost ? ( boost => $self->boost ) : () ); my @elements = map { ( '' => $_->to_element ) } $self->fields; return XML::Easy::Element->new( 'doc', \%attr, XML::Easy::Content->new( [ @elements, '' ] ), ); } sub to_xml { my $self = shift; return XML::Easy::Text::xml10_write_element( $self->to_element ); } 1; __END__ =head1 NAME WebService::Solr::Document - A document object =head1 SYNOPSIS my $doc = WebService::Solr::Document->new; $doc->add_fields( @fields ); $doc->boost( 2.0 ); my $id = $doc->value_for( 'id' ); my @subjects = $doc->values_for( 'subject' ); =head1 DESCRIPTION This class represents a basic document object, which is basically a collection of fields. =head1 ACCESSORS =over 4 =item * fields - an array of fields =item * boost - a floating-point "boost" value =back =head1 METHODS =head2 new( @fields|\@fields ) Constructs a new document object given C<@fields>. A field can be a L object, or a structure accepted by Cnew>. =head2 BUILDARGS( @args ) A Moose override to allow our custom constructor. =head2 add_fields( @fields|\@fields ) Adds C<@fields> to the document. =head2 field_names Returns a list of field names that are in this document. =head2 value_for( $name ) Returns the first value for C<$name>. =head2 values_for( $name ) Returns all values for C<$name>. =head2 to_element( ) Serializes the object to an XML::Easy::Element object. =head2 to_xml( ) Serializes the object to xml. =head1 AUTHORS Brian Cassidy Ebricas@cpan.orgE Kirk Beers =head1 COPYRIGHT AND LICENSE Copyright 2008-2013 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 WebService-Solr-0.22/lib/WebService/Solr/Field.pm0000644000101700007640000000407312115143471020676 0ustar alesterispcpackage WebService::Solr::Field; use XML::Easy::Element; use XML::Easy::Content; use XML::Easy::Text (); sub new { my ( $class, $name, $value, $opts ) = @_; $opts ||= {}; die "name required" unless defined $name; die "value required" unless defined $value; my $self = { name => $name, value => $value, %{ $opts }, }; return bless $self, $class; } sub name { my $self = shift; $self->{ name } = $_[ 0 ] if @_; return $self->{ name }; } sub value { my $self = shift; $self->{ value } = $_[ 0 ] if @_; return $self->{ value }; } sub boost { my $self = shift; $self->{ boost } = $_[ 0 ] if @_; return $self->{ boost }; } sub to_element { my $self = shift; my %attr = ( $self->boost ? ( boost => $self->boost ) : () ); return XML::Easy::Element->new( 'field', { name => $self->name, %attr }, XML::Easy::Content->new( [ $self->value ] ), ); } sub to_xml { my $self = shift; return XML::Easy::Text::xml10_write_element( $self->to_element ); } 1; __END__ =head1 NAME WebService::Solr::Field - A field object =head1 SYNOPSIS my $field = WebService::Solr::Field->new( foo => 'bar' ); =head1 DESCRIPTION This class represents a field from a document, which is basically a name-value pair. =head1 ACCESSORS =over 4 =item * name - the field's name =item * value - the field's value =item * boost - a floating-point boost value =back =head1 METHODS =head2 new( $name => $value, \%options ) Creates a new field object. Currently, the only option available is a "boost" value. =head2 BUILDARGS( @args ) A Moose override to allow our custom constructor. =head2 to_element( ) Serializes the object to an XML::Easy::Element object. =head2 to_xml( ) Serializes the object to xml. =head1 AUTHORS Brian Cassidy Ebricas@cpan.orgE Kirk Beers =head1 COPYRIGHT AND LICENSE Copyright 2008-2013 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 WebService-Solr-0.22/lib/WebService/Solr/Query.pm0000644000101700007640000002400012115143471020750 0ustar alesterispcpackage WebService::Solr::Query; use Any::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 ( sort 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 ) = @_; if ( ref $v ) { $v = $$v; } else { $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 ( sort 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 Any::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 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). =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 Literal Queries Specifying a scalar ref as a value in a key-value pair will allow arbitrary queries to be sent across the line. B This will bypass any data massaging done on regular strings, thus the onus of properly escaping the data is left to the user. my $q = WebService::Solr::Query->new( { '*' => \'*' } ) # RESULT (*:*) =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 Values sent to C are automatically escaped for you. =head2 unescape( $value ) Unescapes values escaped in C. =head2 D Debugging constant, default: off. =head2 BUILDARGS Moose method to handle input to C. =head1 SEE ALSO =over 4 =item * L =item * http://wiki.apache.org/solr/SolrQuerySyntax =back =head1 AUTHORS Brian Cassidy Ebricas@cpan.orgE Jos Boumans Ekane@cpan.orgE =head1 COPYRIGHT AND LICENSE Copyright 2008-2013 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 WebService-Solr-0.22/MANIFEST0000644000101700007640000000122212126653204014716 0ustar alesterispcChanges inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm 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 META.yml README.md t/document.t t/field.t 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 t/request/optimize.t t/request/ping.t t/request/rollback.t t/request/search.t t/response.t t/use.t WebService-Solr-0.22/README.md0000644000101700007640000000054412115144135015046 0ustar alesterispc# WebService::Solr WebService::Solr is a Perl module to interface with the Solr web service. To install: perl Makefile.PL make make test make install # Copyright & License Copyright 2008-2013 National Adult Literacy Database This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. WebService-Solr-0.22/META.yml0000644000101700007640000000143312126653174015050 0ustar alesterispc--- abstract: 'Module to interface with the Solr (Lucene) webservice' author: - 'Brian Cassidy ' build_requires: ExtUtils::MakeMaker: 6.59 Test::Mock::LWP: 0.05 Test::More: 0.94 XML::Simple: 0 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.06' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: WebService-Solr no_index: directory: - inc - t requires: Any::Moose: 0.16 Data::Page: 0 Data::Pageset: 0 Encode: 0 JSON::XS: 0 LWP::UserAgent: 0 URI: 1.28 XML::Easy: 0 perl: 5.8.0 resources: license: http://dev.perl.org/licenses/ repository: http://github.com/bricas/webservice-solr version: 0.22 WebService-Solr-0.22/t/0000755000101700007640000000000012126653250014034 5ustar alesterispcWebService-Solr-0.22/t/live.t0000644000101700007640000000046712115143232015157 0ustar alesterispcuse Test::More; use strict; use warnings; use WebService::Solr; plan skip_all => '$ENV{SOLR_SERVER} not set' unless $ENV{ SOLR_SERVER }; plan tests => 2; my $solr = WebService::Solr->new( $ENV{ SOLR_SERVER } ); isa_ok( $solr, 'WebService::Solr' ); my $r = $solr->ping; ok( $r, 'ping()' ); done_testing(); WebService-Solr-0.22/t/pod_coverage.t0000644000101700007640000000027712115143232016654 0ustar alesterispcuse strict; use warnings; use Test::More; eval "use Test::Pod::Coverage 1.00"; plan skip_all => "Test::Pod::Coverage 1.00 required for testing POD coverage" if $@; all_pod_coverage_ok(); WebService-Solr-0.22/t/request/0000755000101700007640000000000012126653250015524 5ustar alesterispcWebService-Solr-0.22/t/request/add.t0000644000101700007640000000214612115143232016434 0ustar alesterispcuse strict; use warnings; use Test::More tests => 11; use Test::Mock::LWP; use XML::Simple; use HTTP::Headers; use WebService::Solr; $Mock_ua->mock( request => sub { _test_req( @{ $_[ 1 ]->new_args } ); return HTTP::Response->new; } ); $Mock_response->mock( is_error => sub { return 0 } ); my $solr = WebService::Solr->new( undef, { autocommit => 0 } ); isa_ok( $solr, 'WebService::Solr' ); my $expect; { is $solr->last_response, undef, "The last_response attribute hasn't been set yet"; $expect = { doc => { field => { name => 'foo', content => 'bar' } } }; $solr->add( { foo => 'bar' } ); isa_ok $solr->last_response, 'WebService::Solr::Response'; $solr->update( { foo => 'bar' } ); } sub _test_req { is( $_[ 2 ]->path, '/solr/update', 'add() path' ); is_deeply( { $_[ 2 ]->query_form }, { wt => 'json' }, 'add() params' ); is_deeply( $_[ 3 ]->header( 'Content_Type' ), 'text/xml; charset=utf-8', 'add() headers' ); my $struct = XMLin( $_[ 4 ], KeepRoot => 1 ); is_deeply( $struct, { add => $expect }, 'add/update xml' ); } WebService-Solr-0.22/t/request/rollback.t0000644000101700007640000000131012115143232017465 0ustar alesterispcuse strict; use warnings; use Test::More tests => 4; use Test::Mock::LWP; use XML::Simple; use HTTP::Headers; use WebService::Solr; $Mock_ua->mock( request => sub { _test_req( @{ $_[ 1 ]->new_args } ); return HTTP::Response->new; } ); $Mock_response->mock( is_error => sub { return 0 } ); 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' ); } WebService-Solr-0.22/t/request/optimize.t0000644000101700007640000000211612115143232017541 0ustar alesterispcuse strict; use warnings; use Test::More tests => 21; use Test::Mock::LWP; use XML::Simple; use HTTP::Headers; use WebService::Solr; $Mock_ua->mock( request => sub { _test_req( @{ $_[ 1 ]->new_args } ); return HTTP::Response->new; } ); $Mock_response->mock( is_error => sub { return 0 } ); my $solr = WebService::Solr->new; isa_ok( $solr, 'WebService::Solr' ); my $opt; for ( {}, { waitFlush => 'true', waitSearcher => 'true' }, { waitFlush => 'true', waitSearcher => 'false' }, { waitFlush => 'false', waitSearcher => 'true' }, { waitFlush => 'false', waitSearcher => 'false' }, ) { $opt = $_; $solr->optimize( $_ ); } sub _test_req { is( $_[ 2 ]->path, '/solr/update', 'optimize() path' ); is_deeply( { $_[ 2 ]->query_form }, { wt => 'json' }, 'optimize() params' ); is( $_[ 3 ]->header( 'Content_Type' ), 'text/xml; charset=utf-8', 'optimize() headers' ); my $struct = XMLin( $_[ 4 ], KeepRoot => 1 ); is_deeply( $struct, { optimize => $opt }, 'optimize() xml' ); } WebService-Solr-0.22/t/request/search.t0000644000101700007640000000163212115143232017150 0ustar alesterispcuse strict; use warnings; use Test::More tests => 5; use Test::Mock::LWP; use WebService::Solr; $Mock_ua->mock( post => sub { my $mock = shift; my $uri = shift; my $params = { @_ }; _test_req( $uri, $params ); return HTTP::Response->new; } ); $Mock_response->mock( is_error => sub { return 0 } ); my $solr = WebService::Solr->new(); isa_ok( $solr, 'WebService::Solr' ); my ( $expect_path, $expect_params ); { $expect_path = '/solr/select'; $expect_params = { q => 'foo', wt => 'json' }; is $solr->last_response, undef, "The last_response attribute hasn't been set yet"; $solr->search( 'foo' ); isa_ok $solr->last_response, 'WebService::Solr::Response'; } sub _test_req { my( $uri, $params ) = @_; is( $uri->path, $expect_path, 'search() path' ); is_deeply( $params->{ Content }, $expect_params, 'search() params in post content' ); } WebService-Solr-0.22/t/request/delete.t0000644000101700007640000000217312115143232017146 0ustar alesterispcuse strict; use warnings; use Test::More tests => 17; use Test::Mock::LWP; use XML::Simple; use HTTP::Headers; use WebService::Solr; $Mock_ua->mock( request => sub { _test_req( @{ $_[ 1 ]->new_args } ); return HTTP::Response->new; } ); $Mock_response->mock( is_error => sub { return 0 } ); my $solr = WebService::Solr->new( undef, { autocommit => 0 } ); isa_ok( $solr, 'WebService::Solr' ); my $expect; { $expect = { id => 1234 }; $solr->delete_by_id( 1234 ); } { $expect = { query => 'name:DDR' }; $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' ); is( $_[ 3 ]->header( 'Content_Type' ), 'text/xml; charset=utf-8', 'delete() headers' ); my $struct = XMLin( $_[ 4 ], KeepRoot => 1 ); is_deeply( $struct, { delete => $expect }, 'delete() xml' ); } WebService-Solr-0.22/t/request/ping.t0000644000101700007640000000117612115143232016643 0ustar alesterispcuse strict; use warnings; use Test::More tests => 4; use Test::Mock::LWP; use WebService::Solr; $Mock_ua->mock( get => sub { _test_req( $_[ 1 ] ); return HTTP::Response->new; } ); $Mock_response->mock( is_error => sub { return 0 } ); my $solr = WebService::Solr->new(); isa_ok( $solr, 'WebService::Solr' ); my $expect; { $expect = 'http://localhost:8983/solr/admin/ping'; is $solr->last_response, undef, "The last_response attribute hasn't been set yet"; $solr->ping(); isa_ok $solr->last_response, 'WebService::Solr::Response'; } sub _test_req { is( $_[ 0 ], $expect, 'ping() url' ); } WebService-Solr-0.22/t/request/commit.t0000644000101700007640000000204612115143232017173 0ustar alesterispcuse strict; use warnings; use Test::More tests => 21; use Test::Mock::LWP; use XML::Simple; use HTTP::Headers; use WebService::Solr; $Mock_ua->mock( request => sub { _test_req( @{ $_[ 1 ]->new_args } ); return HTTP::Response->new; } ); $Mock_response->mock( is_error => sub { return 0 } ); my $solr = WebService::Solr->new; isa_ok( $solr, 'WebService::Solr' ); my $opt; for ( {}, { waitFlush => 'true', waitSearcher => 'true' }, { waitFlush => 'true', waitSearcher => 'false' }, { waitFlush => 'false', waitSearcher => 'true' }, { waitFlush => 'false', waitSearcher => 'false' }, ) { $opt = $_; $solr->commit( $_ ); } sub _test_req { is( $_[ 2 ]->path, '/solr/update', 'commit() path' ); is_deeply( { $_[ 2 ]->query_form }, { wt => 'json' }, 'commit() params' ); is( $_[ 3 ]->header( 'Content_Type' ), 'text/xml; charset=utf-8', 'commit() headers' ); my $struct = XMLin( $_[ 4 ], KeepRoot => 1 ); is_deeply( $struct, { commit => $opt }, 'commit() xml' ); } WebService-Solr-0.22/t/response.t0000644000101700007640000000462312115143232016054 0ustar alesterispcuse strict; use warnings; ### XXX Whitebox tests! use Test::More tests => 5; use HTTP::Headers; use HTTP::Response; use WebService::Solr::Response; my $Class = 'WebService::Solr::Response'; # $r = HTTP::Response->new( $code, $msg, $header, $content ) my $SolrResponse = HTTP::Response->new( 200 => 'OK', HTTP::Headers->new, q[{"responseHeader":{"status":0,"QTime":24,"params":{"rows":"2","sort":"created_dt desc","wt":"json","start":"4","q":"foo"}},"response":{"numFound":10,"start":4,"docs":[{"name":["foo1"]},{"name":["foo2"]}]}}], ); my $Obj; subtest 'Create tests' => sub { ok( $SolrResponse, 'Created dummy Solr response' ); $Obj = $Class->new( $SolrResponse ); ok( $Obj, " Created $Class object from $SolrResponse" ); isa_ok( $Obj, $Class ); }; subtest 'Check accessors' => sub { ok( $Obj, 'Testing accessors' ); for my $acc ( qw[status_code status_message is_success is_error content docs pager pageset] ) { ok( $Obj->can( $acc ), " Obj->can( $acc )" ); ok( defined $Obj->$acc, " Value = " . $Obj->$acc ); } }; subtest 'Check docs' => sub { for my $doc ( $Obj->docs ) { ok( $doc, "Testing $doc" ); isa_ok( $doc, 'WebService::Solr::Document' ); like( $doc->value_for( 'name' ), qr/foo/, " Name = " . $doc->value_for( 'name' ) ); } }; subtest 'Check pagers' => sub { for my $pager ( $Obj->pager, $Obj->pageset, $Obj->pageset( mode => 'fixed' ) ) { ok( $pager, "Pager retrieved: $pager" ); is( $pager->total_entries, 10, " Total entries = 10" ); is( $pager->entries_per_page, 2, " Entries per page = 2" ); is( $pager->first_page, 1, " First page = 1" ); is( $pager->last_page, 5, " Last page = 5" ); is( $pager->current_page, 3, " Current page = 2" ); } }; subtest 'Special case: 0 rows' => sub { 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' ); }; done_testing(); WebService-Solr-0.22/t/document.t0000644000101700007640000000761212115143232016035 0ustar alesterispcuse Test::More tests => 23; use strict; use warnings; use WebService::Solr::Document; use WebService::Solr::Field; use JSON::XS; my @fields = ( [ id => 1, { boost => 1.6 } ], [ sku => 'A6B9A', { boost => '1.0' } ], [ manu => 'The Bird Book', { boost => '7.1' } ], [ weight => '4.0', { boost => 3.2 } ], [ name => 'Sally Jesse Raphael' ], ); my @field_objs = map { WebService::Solr::Field->new( @$_ ) } @fields; { my $expect = join( '', '', '1', 'A6B9A', 'The Bird Book', '4.0', 'Sally Jesse Raphael', '' ); { my $doc = WebService::Solr::Document->new( @fields[ 0 .. 4 ] ); isa_ok( $doc, 'WebService::Solr::Document' ); $doc->boost( '3.0' ); is( $doc->to_xml, $expect, 'to_xml(), array refs' ); } { my $doc = WebService::Solr::Document->new( @field_objs[ 0 .. 4 ] ); isa_ok( $doc, 'WebService::Solr::Document' ); $doc->boost( '3.0' ); is( $doc->to_xml, $expect, 'to_xml(), objs' ); } { my $doc = WebService::Solr::Document->new(); isa_ok( $doc, 'WebService::Solr::Document' ); $doc->boost( '3.0' ); $doc->add_fields( @field_objs[ 0 .. 4 ] ); is( $doc->to_xml, $expect, 'to_xml(), add_fields()' ); } { my $doc = WebService::Solr::Document->new( $field_objs[ 0 ], @fields[ 1 .. 3 ], $field_objs[ 4 ] ); isa_ok( $doc, 'WebService::Solr::Document' ); $doc->boost( '3.0' ); is( $doc->to_xml, $expect, 'to_xml(), mixed' ); } } { my $doc = WebService::Solr::Document->new( key => 'value' ); isa_ok( $doc, 'WebService::Solr::Document' ); is( $doc->to_xml, 'value', 'to_xml(), key=>val' ); } { my $doc = WebService::Solr::Document->new( key => 'value', $field_objs[ 0 ] ); isa_ok( $doc, 'WebService::Solr::Document' ); is( $doc->to_xml, 'value1', 'to_xml(), key=>val + obj' ); } { my $doc = WebService::Solr::Document->new( $field_objs[ 0 ], key => 'value' ); isa_ok( $doc, 'WebService::Solr::Document' ); is( $doc->to_xml, '1value', 'to_xml(), obj + key=>val' ); } { my $doc = WebService::Solr::Document->new( @field_objs[ 0 .. 4 ], $field_objs[ 1 ] ); isa_ok( $doc, 'WebService::Solr::Document' ); { my @values = $doc->values_for( 'id' ); is_deeply( \@values, [ 1 ], 'values_for() -- single value' ); } { my @values = $doc->values_for( 'sku' ); is_deeply( \@values, [ 'A6B9A', 'A6B9A' ], 'values_for() -- multi-value' ); } { my @values = $doc->values_for( 'dne' ); is_deeply( \@values, [], 'values_for() -- no values' ); } } { my $doc = WebService::Solr::Document->new( x => [ 1, 2, 3 ] ); isa_ok( $doc, 'WebService::Solr::Document' ); is( scalar @{ $doc->fields }, 3, 'arrayref of values to fields' ); } { my $doc = WebService::Solr::Document->new( @fields[ 0 .. 4 ] ); is_deeply( [ sort( $doc->field_names ) ], [ qw(id manu name sku weight) ], 'field_names' ); } { my $doc = WebService::Solr::Document->new( bools => decode_json( q/{"arr": [true,false,true]}/ )->{ arr } ); isa_ok( $doc, 'WebService::Solr::Document' ); is_deeply( [ 1, 0, 1 ], [ $doc->values_for( 'bools' ) ], 'boolean arrays' ); } WebService-Solr-0.22/t/field.t0000644000101700007640000000256512115143232015304 0ustar alesterispcuse Test::More tests => 9; use strict; use warnings; use WebService::Solr::Field; { my $f = WebService::Solr::Field->new( id => '0001' ); my $expected = '0001'; is( $f->to_xml, $expected, 'to_xml(), default attrs' ); } { my $f = WebService::Solr::Field->new( id => '0001', { boost => 3 } ); my $expected = '0001'; is( $f->to_xml, $expected, 'to_xml(), all attrs' ); } { my $f = WebService::Solr::Field->new( id => '0001', { boost => 3.1 } ); my $expected = '0001'; is( $f->to_xml, $expected, 'to_xml(), all attrs, float for boost' ); } { my $f = eval { WebService::Solr::Field->new( undef() => '0001' ) }; ok( !defined $f, 'name required' ); ok( $@, 'name required' ); } { my $f = eval { WebService::Solr::Field->new( id => undef ) }; ok( !defined $f, 'value required' ); ok( $@, 'value required' ); } # XML escaping { my $f = WebService::Solr::Field->new( foo => 'This & That' ); my $expected = 'This & That'; is( $f->to_xml, $expected, 'to_xml(), escaped (1)' ); } { my $f = WebService::Solr::Field->new( foo => 'This & That' ); my $expected = 'This &amp; That'; is( $f->to_xml, $expected, 'to_xml(), escaped (2)' ); } WebService-Solr-0.22/t/use.t0000644000101700007640000000036512115143232015011 0ustar alesterispcuse strict; use warnings; use Test::More tests => 1; use WebService::Solr; use WebService::Solr::Field; use WebService::Solr::Document; use WebService::Solr::Query; use WebService::Solr::Response; pass( 'All modules loaded' ); done_testing(); WebService-Solr-0.22/t/query.t0000644000101700007640000001304012115143232015354 0ustar alesterispcuse Test::More tests => 7; use strict; use warnings; use WebService::Solr::Query; subtest 'Unescapes' => sub { is( WebService::Solr::Query->escape( '(1+1):2' ), '\(1\+1\)\:2', 'escape' ); is( WebService::Solr::Query->unescape( '\(1\+1\)\:2' ), '(1+1):2', 'unescape' ); }; subtest 'Basic queries' => sub { # default field _check( query => { -default => 'space' }, expect => '("space")' ); _check( query => { -default => [ 'star trek', 'star wars' ] }, expect => '(("star trek" OR "star wars"))' ); # scalarref pass-through _check( query => { '*' => \'*' }, expect => '(*:*)' ); # 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"))' ); }; subtest 'Basic query with escape' => sub { _check( query => { -default => 'sp(a)ce' }, expect => '("sp\(a\)ce")' ); _check( query => { title => 'Spaceb(a)lls' }, expect => '(title:"Spaceb\(a\)lls")' ); }; subtest 'Simple ops' => sub { # 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)' ); }; subtest 'Ops with escape' => sub { _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)' ); }; subtest 'Require and prohibit' => sub { _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")' ); }; subtest 'Nested and/or operators' => sub { _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})))], ); }; done_testing(); 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 } ); } WebService-Solr-0.22/t/pod.t0000644000101700007640000000023312115143232014771 0ustar alesterispcuse strict; use warnings; use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); WebService-Solr-0.22/Changes0000644000101700007640000000611112126652514015065 0ustar alesterispcRevision history for Perl extension WebService::Solr. 0.22 2013-04-02 17:03 - Speed up ->value_for() to lazily find the first field, rather than processing all of ->values_for() and taking the first value. 0.21 2012-11-29 - Get rid of use_ok() in the tests. - Minor documentation fixes. 0.20 2012-11-29 - Avoid random hash key ordering issues (perl 5.17.6) when testing WebService::Solr::Query (RT #81527) 0.19 2012-05-25 - Merge default_params in with other params in the post body 0.18 2012-05-24 - Force previous switch to a post request to be utf-8 encoded 0.17 2012-03-29 - Changed the solr search to use a post request (Robert Ward) 0.16 2011-10-11 - Switch to Any::Moose so that Mouse may be used (Kevin Goess) 0.15 2011-07-14 - Add a last_response accessor to get the most recent WebService::Solr::Response object (Dan Brook) 0.14 2011-06-13 - Fix broken logic for figuring out rows per page when not explicitly specified. It was broken on the last page when the number of rows returned was less than the default. We now just assume 10 rows which is the default in Solr. 0.13 2011-05-05 - Replace XML::Generator with XML::Easy and de-mooseify the Document and Field classes to help speed up (about 3x) document creation and serialization. 0.12 2011-04-12 - Clean up docs in relation to autocommit - Handle blessed field values (Dan Brook) 0.11 2010-10-27 - Add a note about enabling Keep-Alive connections (Stijn Prompers) - Add field_names method to Document (Cory Watson, Craig Hall) 0.10 2010-03-17 - Add spellcheck() convenience method to Response object - Fix exception when response contained no documents 0.09 2009-12-04 - 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 2009-10-14 - Allow scalar ref value in WebService::Solr::Query, which works like SQL::Abstract (literal query) - Fix status_message and status_code in Response - Add Data::Pageset capabilities to Response (Jos Boumans) - Ensure compatibility with older versions of Encode by making sure we pass a string to encode() (Gert Brinkmann) 0.07 2009-06-26 - Trap JSON::XS exceptions (Jos Boumans) - Provide an abstract query generator: WebService::Solr::Query (Jos Boumans, Brian Cassidy) 0.06 2009-05-07 - Add auto_suggest to hit the new Solr 1.4 /autoSuggest API (RT #45798) - Refactor a basic GET request into its own public method (generic_solr_request) 0.05 2009-04-13 - Confess upon HTTP error (Leon Brocard) - Send UTF-8 requests to keep new LWP happy (Leon Brocard) 0.04 2009-03-02 - add make_immutable to Solr.pm - be paranoid about XML escaping (Gert Brinkmann) 0.03 2009-01-15 - fix typo (Thanks cog) - pod fixes - try to work around old LWP versions when setting HTTP headers - require URI >= 1.28 - require XML::Generator >= 0.94 0.02 2008-10-09 - fix pager creation, missing prereq - add a simple facet_counts() shortcut method 0.01 2008-10-07 - original version; WebService-Solr-0.22/Makefile.PL0000644000101700007640000000112312115144065015535 0ustar alesterispcuse inc::Module::Install 1.06; perl_version '5.008'; name 'WebService-Solr'; all_from 'lib/WebService/Solr.pm'; requires 'LWP::UserAgent'; requires 'URI' => '1.28'; requires 'Data::Page'; requires 'Data::Pageset'; requires 'XML::Easy'; requires 'JSON::XS'; requires 'Any::Moose' => '0.16'; # 0.16 doesn't force Mouse dep requires 'Encode'; test_requires 'Test::More' => '0.94', # want note(), explain(), subtest() and done_testing() test_requires 'XML::Simple'; test_requires 'Test::Mock::LWP' => '0.05'; tests_recursive; repository 'http://github.com/bricas/webservice-solr'; WriteAll; WebService-Solr-0.22/inc/0000755000101700007640000000000012126653250014342 5ustar alesterispcWebService-Solr-0.22/inc/Module/0000755000101700007640000000000012126653250015567 5ustar alesterispcWebService-Solr-0.22/inc/Module/Install/0000755000101700007640000000000012126653250017175 5ustar alesterispcWebService-Solr-0.22/inc/Module/Install/Metadata.pm0000644000101700007640000004327712126653174021275 0ustar alesterispc#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords author }; *authors = \&author; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the really old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } $self->{values}{all_from} = $file; # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless @{$self->author || []}; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $file ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => '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, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license 2\.0' => 'artistic_2', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than one bugtracker link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+(v?[\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } 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?)\.(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) ) { # Numify $v = $v + 0; } return $v; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } 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 my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; WebService-Solr-0.22/inc/Module/Install/Makefile.pm0000644000101700007640000002743712126653174021272 0ustar alesterispc#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; my $name = shift; my $args = $self->makemaker_args; $args->{$name} = defined $args->{$name} ? join( ' ', $args->{$name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $args->{INSTALLDIRS} = $self->installdirs; } my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_} ) } keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if ( my $preop = $self->admin->preop($user_preop) ) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "+< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 544 WebService-Solr-0.22/inc/Module/Install/WriteAll.pm0000644000101700007640000000237612126653174021273 0ustar alesterispc#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. 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; } 1; WebService-Solr-0.22/inc/Module/Install/Can.pm0000644000101700007640000000615712126653174020252 0ustar alesterispc#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # Check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # Can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 236 WebService-Solr-0.22/inc/Module/Install/Fetch.pm0000644000101700007640000000462712126653174020602 0ustar alesterispc#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; WebService-Solr-0.22/inc/Module/Install/Win32.pm0000644000101700007640000000340312126653174020442 0ustar alesterispc#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.06'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; WebService-Solr-0.22/inc/Module/Install/Base.pm0000644000101700007640000000214712126653174020416 0ustar alesterispc#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.06'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { ! $_[0]->admin->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 WebService-Solr-0.22/inc/Module/Install.pm0000644000101700007640000003013512126653173017541 0ustar alesterispc#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use Cwd (); use File::Find (); use File::Path (); use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # 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 = '1.06'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE #------------------------------------------------------------- # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[1]) <=> _version($_[2]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2012 Adam Kennedy.