WebService-Solr-0.23/ 0000755 0001017 0000764 00000000000 12275263645 013604 5 ustar alester ispc WebService-Solr-0.23/lib/ 0000755 0001017 0000764 00000000000 12275263645 014352 5 ustar alester ispc WebService-Solr-0.23/lib/WebService/ 0000755 0001017 0000764 00000000000 12275263645 016410 5 ustar alester ispc WebService-Solr-0.23/lib/WebService/Solr.pm 0000644 0001017 0000764 00000024447 12275262370 017672 0 ustar alester ispc package 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.23';
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 serialized 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 correspondingly 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-2014 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.23/lib/WebService/Solr/ 0000755 0001017 0000764 00000000000 12275263645 017327 5 ustar alester ispc WebService-Solr-0.23/lib/WebService/Solr/Response.pm 0000644 0001017 0000764 00000012177 12167275253 021471 0 ustar alester ispc package 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.23/lib/WebService/Solr/Document.pm 0000644 0001017 0000764 00000007011 12167275253 021440 0 ustar alester ispc package 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.23/lib/WebService/Solr/Field.pm 0000644 0001017 0000764 00000004073 12167275253 020712 0 ustar alester ispc package 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.23/lib/WebService/Solr/Query.pm 0000644 0001017 0000764 00000024244 12275260440 020766 0 ustar alester ispc package 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;
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?
$v = [ @$v ]; # Copy the array because we're going to be modifying it.
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";
}
sub __dumper {
require Data::Dumper;
return Data::Dumper::Dumper( @_ );
}
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-2014 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.23/MANIFEST 0000644 0001017 0000764 00000001254 12275263627 014737 0 ustar alester ispc Changes
dev/issue22.pl
foo
foo.pl
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.23/foo 0000644 0001017 0000764 00000010641 12275014161 014277 0 ustar alester ispc Calling the first stringify
# WebService::Solr::Query::_dispatch_struct:35: Dispatching to ->_struct_ARRAY $VAR1 = [
# {
# 'title' => [
# '-and',
# {
# '-prohibit' => 'star'
# },
# {
# '-prohibit' => 'wars'
# }
# ]
# }
# ];
#
# WebService::Solr::Query::_dispatch_struct:35: Dispatching to ->_struct_HASH $VAR1 = {
# 'title' => [
# '-and',
# {
# '-prohibit' => 'star'
# },
# {
# '-prohibit' => 'wars'
# }
# ]
# };
#
# WebService::Solr::Query::_struct_HASH:52: Key => title, value => $VAR1 = [
# '-and',
# {
# '-prohibit' => 'star'
# },
# {
# '-prohibit' => 'wars'
# }
# ];
#
# WebService::Solr::Query::_struct_HASH:61: Dispatch ->_dispatch_value title, $VAR1 = [
# '-and',
# {
# '-prohibit' => 'star'
# },
# {
# '-prohibit' => 'wars'
# }
# ];
#
# WebService::Solr::Query::_dispatch_value:108: Special operator detected: AND $VAR1 = [
# {
# '-prohibit' => 'star'
# },
# {
# '-prohibit' => 'wars'
# }
# ];
#
# WebService::Solr::Query::_dispatch_value:114: Dispatch ->_dispatch_struct({ title, $VAR1 = {
# '-prohibit' => 'star'
# };
#})
# WebService::Solr::Query::_dispatch_struct:35: Dispatching to ->_struct_HASH $VAR1 = {
# 'title' => {
# '-prohibit' => 'star'
# }
# };
#
# WebService::Solr::Query::_struct_HASH:52: Key => title, value => $VAR1 = {
# '-prohibit' => 'star'
# };
#
# WebService::Solr::Query::_struct_HASH:61: Dispatch ->_dispatch_value title, $VAR1 = {
# '-prohibit' => 'star'
# };
#
# WebService::Solr::Query::_dispatch_value:135: Dispatch ->_value_HASH title, $VAR1 = {
# '-prohibit' => 'star'
# };
#
# WebService::Solr::Query::_value_HASH:172: Dispatch ->_op_prohibit title, $VAR1 = {
# '-prohibit' => 'star'
# };
#
# WebService::Solr::Query::_value_HASH:179: Returning: -title:"star"
# WebService::Solr::Query::_dispatch_value:140: Returning: -title:"star"
# WebService::Solr::Query::_struct_HASH:70: Returning: -title:"star"
# WebService::Solr::Query::_dispatch_struct:39: Returned: -title:"star"
# WebService::Solr::Query::_dispatch_value:123: Returned -title:"star"
# WebService::Solr::Query::_dispatch_value:114: Dispatch ->_dispatch_struct({ title, $VAR1 = {
# '-prohibit' => 'wars'
# };
#})
# WebService::Solr::Query::_dispatch_struct:35: Dispatching to ->_struct_HASH $VAR1 = {
# 'title' => {
# '-prohibit' => 'wars'
# }
# };
#
# WebService::Solr::Query::_struct_HASH:52: Key => title, value => $VAR1 = {
# '-prohibit' => 'wars'
# };
#
# WebService::Solr::Query::_struct_HASH:61: Dispatch ->_dispatch_value title, $VAR1 = {
# '-prohibit' => 'wars'
# };
#
# WebService::Solr::Query::_dispatch_value:135: Dispatch ->_value_HASH title, $VAR1 = {
# '-prohibit' => 'wars'
# };
#
# WebService::Solr::Query::_value_HASH:172: Dispatch ->_op_prohibit title, $VAR1 = {
# '-prohibit' => 'wars'
# };
#
# WebService::Solr::Query::_value_HASH:179: Returning: -title:"wars"
# WebService::Solr::Query::_dispatch_value:140: Returning: -title:"wars"
# WebService::Solr::Query::_struct_HASH:70: Returning: -title:"wars"
# WebService::Solr::Query::_dispatch_struct:39: Returned: -title:"wars"
# WebService::Solr::Query::_dispatch_value:123: Returned -title:"wars"
# WebService::Solr::Query::_dispatch_value:140: Returning: ((-title:"star") AND (-title:"wars"))
# WebService::Solr::Query::_struct_HASH:70: Returning: ((-title:"star") AND (-title:"wars"))
# WebService::Solr::Query::_dispatch_struct:39: Returned: ((-title:"star") AND (-title:"wars"))
# WebService::Solr::Query::_struct_ARRAY:83: Returning: (((-title:"star") AND (-title:"wars")))
# WebService::Solr::Query::_dispatch_struct:39: Returned: (((-title:"star") AND (-title:"wars")))
Result #1: (((-title:"star") AND (-title:"wars")))
WebService-Solr-0.23/README.md 0000644 0001017 0000764 00000000544 12275256565 015071 0 ustar alester ispc # 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-2014 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.23/META.yml 0000644 0001017 0000764 00000001433 12275262476 015057 0 ustar alester ispc ---
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.23
WebService-Solr-0.23/foo.pl 0000644 0001017 0000764 00000000502 12275254277 014722 0 ustar alester ispc #!perl
# Exercises GitHub issue 22 https://github.com/bricas/webservice-solr/issues/22
use warnings;
use strict;
use lib 'lib';
use Carp::Always;
use WebService::Solr::Query;
my $q = WebService::Solr::Query->new( { '*' => \'* AND -classifications:(4 OR 5)' } );
my $str1 = $q->stringify;
print "Result #1: $str1\n";
WebService-Solr-0.23/t/ 0000755 0001017 0000764 00000000000 12275263645 014047 5 ustar alester ispc WebService-Solr-0.23/t/live.t 0000644 0001017 0000764 00000000467 12167275253 015200 0 ustar alester ispc use 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.23/t/pod_coverage.t 0000644 0001017 0000764 00000000277 12167275253 016675 0 ustar alester ispc use 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.23/t/request/ 0000755 0001017 0000764 00000000000 12275263645 015537 5 ustar alester ispc WebService-Solr-0.23/t/request/add.t 0000644 0001017 0000764 00000002146 12167275253 016455 0 ustar alester ispc use 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.23/t/request/rollback.t 0000644 0001017 0000764 00000001310 12167275253 017506 0 ustar alester ispc use 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.23/t/request/optimize.t 0000644 0001017 0000764 00000002116 12167275253 017562 0 ustar alester ispc use 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.23/t/request/search.t 0000644 0001017 0000764 00000001632 12167275253 017171 0 ustar alester ispc use 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.23/t/request/delete.t 0000644 0001017 0000764 00000002173 12167275253 017167 0 ustar alester ispc use 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.23/t/request/ping.t 0000644 0001017 0000764 00000001176 12167275253 016664 0 ustar alester ispc use 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.23/t/request/commit.t 0000644 0001017 0000764 00000002046 12167275253 017214 0 ustar alester ispc use 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.23/t/response.t 0000644 0001017 0000764 00000004623 12167275253 016075 0 ustar alester ispc use 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.23/t/document.t 0000644 0001017 0000764 00000007612 12167275253 016056 0 ustar alester ispc use 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.23/t/field.t 0000644 0001017 0000764 00000002565 12167275253 015325 0 ustar alester ispc use 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 & That';
is( $f->to_xml, $expected, 'to_xml(), escaped (2)' );
}
WebService-Solr-0.23/t/use.t 0000644 0001017 0000764 00000000365 12167275253 015032 0 ustar alester ispc use 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.23/t/query.t 0000644 0001017 0000764 00000015740 12275256072 015404 0 ustar alester ispc use Test::More tests => 7;
use strict;
use warnings;
use WebService::Solr::Query;
use Data::Dumper;
local $Data::Dumper::Sortkeys=1; # To make sure output is deterministic.
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")'
);
_check(
query => {
title => [ -and => { -prohibit => 'star' }, { -prohibit => 'wars' } ],
},
expect => '(((-title:"star") AND (-title:"wars")))'
);
_check(
query => {
first => [ 'Bob' ],
title => [ -and => { -prohibit => 'star' }, { -prohibit => 'wars' } ],
},
expect => '((first:"Bob") AND ((-title:"star") AND (-title:"wars")))'
);
};
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 {
local $Test::Builder::Level = $Test::Builder::Level + 1;
my %t = @_;
my $expect = $t{expect};
return subtest $expect => sub {
plan tests => 5;
note(explain($t{query}));
my $q = WebService::Solr::Query->new( $t{ query } );
isa_ok( $q, 'WebService::Solr::Query' );
# GitHub issue #22 is a bug where calling $q->stringify modified
# the query in place, and so subsequent calls to $q->stringify
# would blow up. Here, we try it twice to make sure they match.
# Then, we compare the objects before and after.
my $before_dump = Dumper( $q );
my @tries;
for my $try ( 1..2 ) {
eval {
my $str = $q->stringify;
is( $str, $expect, "Stringify matches on try #$try" );
push( @tries, $str );
} or fail( "Try #$try fails with $@" );
}
is( $tries[0], $tries[1], 'Both stringifies are the same' );
my $after_dump = Dumper( $q );
is( $after_dump, $before_dump, 'Before/after dumps of the object are the same' );
};
}
WebService-Solr-0.23/t/pod.t 0000644 0001017 0000764 00000000233 12167275253 015012 0 ustar alester ispc use 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.23/Changes 0000644 0001017 0000764 00000006572 12275262421 015100 0 ustar alester ispc Revision history for Perl extension WebService::Solr.
0.23 2014-02-07 16:58
- Fix a bug in Webservice::Solr::Query::stringify() where it would
sometimes modify the query argument structure passed in. This would
make subsequent calls to stringify be broken and wrong, or even blow up.
- The ::Query module no longer loads Data::Dumper automatically.
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.23/dev/ 0000755 0001017 0000764 00000000000 12275263645 014362 5 ustar alester ispc WebService-Solr-0.23/dev/issue22.pl 0000644 0001017 0000764 00000001204 12275262131 016175 0 ustar alester ispc #!perl
# Exercises GitHub issue 22 https://github.com/bricas/webservice-solr/issues/22
use warnings;
use strict;
use lib 'lib';
use Carp::Always;
use WebService::Solr::Query;
my $q = WebService::Solr::Query->new( { title => [ -and => { -prohibit => 'star' }, { -prohibit => 'wars' } ] } );
print "Calling the first stringify\n";
{use Data::Dumper; local $Data::Dumper::Sortkeys=1; warn Dumper( 'q#1' => $q )}
my $str1 = $q->stringify;
{use Data::Dumper; local $Data::Dumper::Sortkeys=1; warn Dumper( 'q#2' => $q )}
print "Result #1: $str1\n";
print "Calling the second stringify\n";
my $str2 = $q->stringify;
print "Result #2: $str2\n";
WebService-Solr-0.23/Makefile.PL 0000644 0001017 0000764 00000001123 12167275253 015551 0 ustar alester ispc use 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.23/inc/ 0000755 0001017 0000764 00000000000 12275263645 014355 5 ustar alester ispc WebService-Solr-0.23/inc/Module/ 0000755 0001017 0000764 00000000000 12275263645 015602 5 ustar alester ispc WebService-Solr-0.23/inc/Module/Install/ 0000755 0001017 0000764 00000000000 12275263645 017210 5 ustar alester ispc WebService-Solr-0.23/inc/Module/Install/Metadata.pm 0000644 0001017 0000764 00000043277 12275262476 021304 0 ustar alester ispc #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.23/inc/Module/Install/Makefile.pm 0000644 0001017 0000764 00000027437 12275262476 021301 0 ustar alester ispc #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.23/inc/Module/Install/WriteAll.pm 0000644 0001017 0000764 00000002376 12275262476 021302 0 ustar alester ispc #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.23/inc/Module/Install/Can.pm 0000644 0001017 0000764 00000006157 12275262476 020261 0 ustar alester ispc #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.23/inc/Module/Install/Fetch.pm 0000644 0001017 0000764 00000004627 12275262476 020611 0 ustar alester ispc #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.23/inc/Module/Install/Win32.pm 0000644 0001017 0000764 00000003403 12275262476 020451 0 ustar alester ispc #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.23/inc/Module/Install/Base.pm 0000644 0001017 0000764 00000002147 12275262476 020425 0 ustar alester ispc #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.23/inc/Module/Install.pm 0000644 0001017 0000764 00000030135 12275262476 017551 0 ustar alester ispc #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.