view release on metacpan or  search on metacpan

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

sub rollback()
{	my $self = shift;
	$self->serverVersion ge '1.4'
		or error __x"Rollback not supported by solr server";

	$self->_rollback;
}


sub extractDocument(@)
{	my $self  = shift;

	$self->serverVersion ge '1.4'
		or error __x"extractDocument() requires Solr v1.4 or higher";
		
	my %p   = $self->expandExtract(@_);
	my $data;

	# expand* changes '_' into '.'
	my $ct  = delete $p{'content.type'};
	my $fn  = delete $p{file};
	$p{'resource.name'} ||= $fn if $fn && !ref $fn;

	$p{commit} = _to_bool $self->autocommit
		unless exists $p{commit};

	if(defined $p{string})
	{	# try to avoid copying the data, which can be huge
		$data = $ct =~ m!^text/!i
		  ? \encode(utf8 => (ref $p{string} eq 'SCALAR' ? ${$p{string}} : $p{string}))
		  : (ref $p{string} eq 'SCALAR' ? $p{string} : \$p{string} );

		delete $p{string};
	}
	elsif($fn)
	{	local $/;
		if(ref $fn eq 'GLOB') { $data = \<$fn> }
		else
		{	local *IN;
			open IN, '<:raw', $fn or fault __x"Cannot read document from {fn}", fn => $fn;
			$data = \<IN>;
			close IN or fault __x"Read error for document {fn}", fn => $fn;
			$ct ||= $mimetypes->mimeTypeOf($fn);
		}
	}
	else
	{	error __x"Extract requires document as file or string";
	}

	$self->_extract([%p], $data, $ct);
}

sub _extract($) { panic "not implemented" }

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

sub _core_admin($@)
{	my ($self, $action, $params) = @_;
	$params->{core} ||= $self->core;
	
	my $endpoint = $self->endpoint('cores', core => 'admin', params => $params);
	my @params   = %$params;
	my $result   = Apache::Solr::Result->new(params => [ %$params ], endpoint => $endpoint, core => $self);

	$self->request($endpoint, $result);
	$result;
}


sub coreStatus(%)
{	my ($self, %args) = @_;
	$self->_core_admin('STATUS', \%args);
}


sub coreReload(%)
{	my ($self, %args) = @_;
	$self->_core_admin('RELOAD', \%args);
}


sub coreUnload($%)
{	my ($self, %args) = @_;
	$self->_core_admin('UNLOAD', \%args);
}

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

sub _calling_sub()
{	for(my $i=0;$i <10; $i++)
	{	my $sub = (caller $i)[3];
		return $sub if !$sub || index($sub, 'Apache::Solr::') < 0;
	}
}

sub _simpleExpand($$$)
{	my ($self, $p, $prefix) = @_;
	my @p  = ref $p eq 'HASH' ? %$p : @$p;
	my $sv = $self->serverVersion;

	my @t;
	while(@p)
	{	my ($k, $v) = (shift @p, shift @p);
		$k =~ s/_/./g;
		$k = $prefix.$k if defined $prefix && index($k, $prefix)!=0;
		my $param   = $k =~ m/^f\.[^\.]+\.(.*)/ ? $1 : $k;

		my ($dv, $iv);
		if(($dv = $deprecated{$param}) && $sv ge $dv)
		{	my $command = _calling_sub;
			$self->deprecated("$command($param) since $dv");
		}
		elsif(($iv = $introduced{$param}) && $iv gt $sv)
		{	my $command = _calling_sub;
			$self->ignored("$command($param) introduced in $iv");
			next;
		}

		push @t, $k => $boolparams{$param} ? _to_bool($_) : $_
			for ref $v eq 'ARRAY' ? @$v : $v;
	}
	@t;
}

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

	my @s;
	my (@flat, %seen_set);
	while(@_)
	{	my ($k, $v) = (shift, shift);
		$k =~ s/_/./g;
		my @p = split /\./, $k;

		# fields are $set.$more or f.$field.$set.$more
		my $per_field    = $p[0] eq 'f' && @p > 2;
		my ($set, $more) = $per_field ? @p[2,3] : @p[0,1];

		if(my $def = $sets{$set})
		{	$seen_set{$set} = 1;
			!$per_field || $def->[0]
			   or error __x"Set {set} cannot be used per field, in {field}", set => $set, field => $k;

			if(ref $v eq 'HASH')
			{	!$more or error __x"Field {field} is not simple for a set", field => $k;
				push @s, $self->_simpleExpand($v, "$k.");
			}
			elsif($more)    # skip $set=true for now
			{	push @flat, $k => $v;
			}
		}
		elsif(ref $v eq 'HASH')
		{	error __x"Unknown set {set}", set => $set;
		}
		else
		{	push @flat, $k => $v;
		}
	}
	push @flat, %seen_set;
	unshift @s, $self->_simpleExpand(\@flat);
	wantarray ? @s : \@s;
}


sub deprecated($)
{	my ($self, $msg) = @_;
	return if $self->{AS_depr_msg}{$msg}++;  # report only once
	warning __x"Deprecated solr {message}", message => $msg;
}


sub ignored($)
{	my ($self, $msg) = @_;
	return if $self->{AS_ign_msg}{$msg}++;  # report only once
	warning __x"Ignored solr {message}", message => $msg;
}


sub removed($)
{	my ($self, $msg) = @_;
	return if $self->{AS_rem_msg}{$msg}++;  # report only once
	warning __x"Removed solr {message}", message => $msg;
}


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

sub endpoint($@)
{	my ($self, $action, %args) = @_;
	my $core = $args{core} || $self->core;
	my $take = $self->server->clone;    # URI
	$take->path($take->path . (defined $core ? "/$core" : '') . "/$action");

	# make parameters ordered
	my $params = $args{params} || [];
	$params	= [ %$params ] if ref $params eq 'HASH';
	@$params or return $take;

	# remove paramers with undefined value
	my @p = @$params;
	my @params;
	while(@p)
	{	push @params, $p[0] => $p[1] if defined $p[1];
		shift @p, shift @p;
	}

	$take->query_form(@params) if @params;
	$take;
}


sub request($$;$$)
{	my ($self, $url, $result, $body, $body_ct) = @_;

	my $req;
	if($body)
	{	# request with 'form' payload
		$req       = HTTP::Request->new
		  ( POST => $url
		  , [ Content_Type        => $body_ct
			, Content_Disposition => 'form-data; name="content"'
			]
		  , (ref $body eq 'SCALAR' ? $$body : $body)
		  );
	}
	else
	{	# request without payload
		$req = HTTP::Request->new(GET => $url);
	}

	$result->request($req);

	my $resp;
	my $retries = $self->{AS_retry_max};
	my $wait    = $self->{AS_retry_wait};
	my $start   = time;

	while($retries--)
	{	$resp = $self->agent->request($req);
		$result->response($resp);
		my $dec = $result->decoded($self->decodeResponse($resp));

		last if $resp->is_success;

		if($resp->code==500)
		{	$! = ENETDOWN;  # HTTP(500) -> unix error
			alert __x"Solr request failed with {code}, {retries} retries left",
			code => $resp->code, retries => $retries, result => $result;