view release on metacpan or  search on metacpan

lib/Apache/Solr.pm  view on Meta::CPAN

# Copyrights 2012-2025 by [Mark Overmeer].
#  For other contributors see ChangeLog.
# See the manual pages for details on the licensing terms.
# Pod stripped from pm file by OODoc 2.03.
# This code is part of distribution Apache-Solr.  Meta-POD processed with
# OODoc into POD and HTML manual-pages.  See README.md
# Copyright Mark Overmeer.  Licensed under the same terms as Perl itself.

package Apache::Solr;{
our $VERSION = '1.11';
}


use warnings;
use strict;

use Apache::Solr::Tables;
use Log::Report    qw(solr);

use Scalar::Util   qw/blessed/;
use Encode         qw/encode/;
use Scalar::Util   qw/weaken/;

use URI            ();
use LWP::UserAgent ();
use MIME::Types    ();

use constant {
	LATEST_SOLR_VERSION => '9.8',  # newest support by this module
	ENETDOWN    => 100,   # error codes may not be available on all platforms
	ENETUNREACH => 101,   #    so cannot use Errno.
};

# overrule this when your host has a different unique field
our $uniqueKey  = 'id';
my  $mimetypes  = MIME::Types->new;
my  $http_agent;

sub _to_bool($)
{	my $b = shift;
	   !defined $b ? undef
	 : ($b && $b ne 'false' && $b ne 'off') ? 'true' 
	 : 'false';
}


sub new(@)
{	my ($class, %args) = @_;
	if($class eq __PACKAGE__)
	{	my $format = delete $args{format} || 'XML';
		$format eq 'XML' || $format eq 'JSON'
			or panic "unknown communication format '$format' for solr";
		$class .= '::' . $format;
		eval "require $class"; panic $@ if $@;
	}
	(bless {}, $class)->init(\%args)
}

sub init($)
{	my ($self, $args) = @_;
	$self->server($args->{server});
	$self->{AS_core}     = $args->{core};
	$self->{AS_commit}   = exists $args->{autocommit} ? $args->{autocommit} : 1;
	$self->{AS_sversion} = $args->{server_version} || LATEST_SOLR_VERSION;
	$self->{AS_retry_wait} = $args->{retry_wait} // 5;  # seconds
	$self->{AS_retry_max}  = $args->{retry_max}  // 60;

	$http_agent = $self->{AS_agent} =
		$args->{agent} || $http_agent || LWP::UserAgent->new(keep_alive=>1);

	weaken $http_agent;
	$self;
}

#---------------

sub core(;$) { my $s = shift; @_ ? $s->{AS_core}   = shift : $s->{AS_core} }
sub autocommit(;$) { my $s = shift; @_ ? $s->{AS_commit} = shift : $s->{AS_commit} }
sub agent() {shift->{AS_agent}}
sub serverVersion() {shift->{AS_sversion}}


sub server(;$)
{	my ($self, $uri) = @_;
	$uri or return $self->{AS_server};
	$uri = URI->new($uri)
		unless blessed $uri && $uri->isa('URI');
	$self->{AS_server} = $uri;
}


#--------------------------

sub select(@)
{	my $self = shift;
	my $args = @_ && ref $_[0] eq 'HASH' ? shift : {};
	$self->_select($args, scalar $self->expandSelect(@_));
}
sub _select($$) {panic "not extended"}


sub queryTerms(@)
{	my $self  = shift;
	$self->_terms(scalar $self->expandTerms(@_));
}
sub _terms(@) {panic "not implemented"}

#-------------------------------------

sub addDocument($%)
{	my ($self, $docs, %args) = @_;
	$docs  = [ $docs ] if ref $docs ne 'ARRAY';

	my $sv = $self->serverVersion;

	my (%attrs, %params);
	$params{commit} = _to_bool(exists $args{commit} ? $args{commit} : $self->autocommit);

	if(my $cw = $args{commitWithin})
	{	if($sv lt '3.4') { $attrs{commit} = 'true' }
		else { $attrs{commitWithin} = int($cw * 1000) }
	}

	$attrs{overwrite} = _to_bool delete $args{overwrite}
		if exists $args{overwrite};

	foreach my $depr (qw/allowDups overwritePending overwriteCommitted/)
	{	if(exists $args{$depr})
		{	  if($sv ge '4.0') { $self->removed("add($depr)"); delete $args{$depr} }
			elsif($sv ge '1.0') { $self->deprecated("add($depr)") }
			else { $attrs{$depr} = _to_bool delete $args{$depr} }