^sub \w+\( results from the CPAN

^sub \w+\(

Apache-Solr

view release on metacpan or search on metacpan

	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' }

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

		{	  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} }
		}
	}

	$self->_add($docs, \%attrs, \%params);
}


sub commit(%)
{	my ($self, %args) = @_;
	my $sv = $self->serverVersion;

	my %attrs;
	if(exists $args{waitFlush})
	{	  if($sv ge '4.0')
			 { $self->removed("commit(waitFlush)"); delete $args{waitFlush} }
		elsif($sv ge '1.4') { $self->deprecated("commit(waitFlush)") }
		else { $attrs{waitFlush} = _to_bool delete $args{waitFlush} }
	}

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

		else { $attrs{softCommit} = _to_bool delete $args{softCommit} }
	}

	if(exists $args{expungeDeletes})
	{	if($sv lt '1.4') { $self->ignored("commit(expungeDeletes)") }
		else { $attrs{expungeDeletes} = _to_bool delete $args{expungeDeletes} }
	}

	$self->_commit(\%attrs);
}
sub _commit($) {panic "not implemented"}


sub optimize(%)
{	my ($self, %args) = @_;
	my $sv = $self->serverVersion;

	my %attrs;
	if(exists $args{waitFlush})
	{	if($sv ge '4.0') { $self->removed("commit(waitFlush)"); delete $args{waitFlush} }
		elsif($sv ge '1.4') { $self->deprecated("optimize(waitFlush)") }
		else { $attrs{waitFlush} = _to_bool delete $args{waitFlush} }
	}

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

		else { $attrs{softCommit} = _to_bool delete $args{softCommit} }
	}

	if(exists $args{maxSegments})
	{	if($sv lt '1.3') { $self->ignored("optimize(maxSegments)") }
		else { $attrs{maxSegments} = delete $args{maxSegments} }
	}

	$self->_optimize(\%attrs);
}
sub _optimize($) {panic "not implemented"}


sub delete(%)
{	my ($self, %args) = @_;

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

	if(exists $args{fromPending})
	{	$self->deprecated("delete(fromPending)");
		$attrs{fromPending}   = _to_bool delete $args{fromPending};
	}
	if(exists $args{fromCommitted})

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

	my $result;
	if($self->serverVersion ge '1.4' && !$self->isa('Apache::Solr::JSON'))
	{	$result = $self->_delete(\%attrs, \@which);
	}
	else
	{	# old servers accept only one id or query per delete
		$result = $self->_delete(\%attrs, [splice @which, 0, 2]) while @which;
	}
	$result;
}
sub _delete(@) {panic "not implemented"}


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'};

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

			$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;

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

			next;
		}

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


sub expandTerms(@)
{	my $self = shift;
	my $p = @_==1 ? shift : [@_];
	my @t = $self->_simpleExpand($p, 'terms.');
	wantarray ? @t : \@t;
}


sub _expand_flatten($$)
{	my ($self, $v, $prefix) = @_;
	my @l = ref $v eq 'HASH' ? %$v : @$v;
	my @s;
	push @s, $prefix.(shift @l) => (shift @l) while @l;
	@s;
}

sub expandExtract(@)
{	my $self = shift;
	my @p = @_==1 ? @{(shift)} : @_;
	my @s;
	while(@p)
	{	my ($k, $v) = (shift @p, shift @p);
		if(!ref $v || ref $v eq 'SCALAR')
			 { push @s, $k => $v }
		elsif($k eq 'literal' || $k eq 'literals')
			 { push @s, $self->_expand_flatten($v, 'literal.') }
		elsif($k eq 'fmap' || $k eq 'boost' || $k eq 'resource')

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

my %sets =   #also-per-field?
  ( expand  => [0]
  , facet   => [1]
  , hl      => [1]
  , mlt     => [0]
  , stats   => [0]
  , suggest => [0]
  , group   => [0]
  );
 
sub expandSelect(@)
{	my $self = shift;
	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;

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

		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;

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

	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"'
			]

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


	unless($resp->is_success)
	{	$! = $resp->code==500 ? ENETDOWN : ENETUNREACH;
		fault __x"Solr request failed after {elapse} seconds after {retries} retries",
			elapse => time - $start, retries => $self->{AS_retry_max} - $retries -1, result => $result;
	}

	$resp;
}

sub decodeResponse($) { undef }

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

1;

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

our $VERSION = '1.11';
}


use warnings;
use strict;

use Log::Report    qw(solr);


sub new(@) { my $c = shift; (bless {}, $c)->init({@_}) }
sub init($)
{	my ($self, $args) = @_;

	$self->{ASD_boost}    = $args->{boost} || 1.0;
	$self->{ASD_fields}   = [];   # ordered
	$self->{ASD_fields_h} = {};   # grouped by name
	$self->addFields($args->{fields});
	$self;
}


sub fromResult($$)
{	my ($class, $data, $rank) = @_;
	my (@f, %fh);
	
	while(my($k, $v) = each %$data)
	{	my @v = map +{name => $k, content => $_}, ref $v eq 'ARRAY' ? @$v : $v;
		push @f, @v;
		$fh{$k} = \@v;
	}

	my $self = $class->new;
	$self->{ASD_rank}     = $rank;
	$self->{ASD_fields}   = \@f;
	$self->{ASD_fields_h} = \%fh;
	$self;
}

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

sub boost(;$)
{	my $self = shift;
	@_ or return $self->{ASD_boost};
	my $f = $self->field(shift) or return;
	@_ ? $f->{boost} = shift : $f->{boost};
}

sub fieldNames() { my %c; $c{$_->{name}}++ for shift->fields; sort keys %c }


sub uniqueId() {shift->content($Apache::Solr::uniqueKey)}


sub rank() {shift->{ASD_rank}}


sub fields(;$)
{	my $self = shift;
	my $f    = $self->{ASD_fields};
	@_ or return @$f;
	my $name = shift;
	my $fh   = $self->{ASD_fields_h}{$name};   # grouped by name
	$fh ? @$fh : ();
}


sub field($)
{	my $fh = $_[0]->{ASD_fields_h}{$_[1]};
	$fh ? $fh->[0] : undef;
}


sub content($)
{	my $f = $_[0]->field($_[1]);
	$f ? $f->{content} : undef;
}

our $AUTOLOAD;
sub AUTOLOAD
{	my $self = shift;
	(my $fn = $AUTOLOAD) =~ s/.*\:\://;

	  $fn =~ /^_(.*)/    ? $self->content($1)
	: $fn eq 'DESTROY'   ? undef
	: panic "Unknown method $AUTOLOAD (hint: fields start with '_')";
}


sub addField($$%)
{	my $self  = shift;
	my $name  = shift;
	defined $_[0] or return;

	my $field = {   # important to minimalize copying of content
		name    => $name,
		content => (
		    !ref $_[0]            ? shift
		  : ref $_[0] eq 'SCALAR' ? ${shift()}
		  :                         shift

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

	my %args  = @_;
	$field->{boost}  = $args{boost} || 1.0;
	$field->{update} = $args{update};

	push @{$self->{ASD_fields}}, $field;
	push @{$self->{ASD_fields_h}{$name}}, $field;
	$field;
}


sub addFields($%)
{	my ($self, $h, @args) = @_;
	# pass content by ref to avoid a copy of potentially huge field.
	if(ref $h eq 'ARRAY')
	{	for(my $i=0; $i < @$h; $i+=2)
		{	$self->addField($h->[$i] => \$h->[$i+1], @args);
		}
	}
	else
	{	$self->addField($_ => \$h->{$_}, @args) for sort keys %$h;
	}

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

use strict;

use Log::Report          qw(solr);

use Apache::Solr::Result ();
use HTTP::Request        ();
use JSON                 ();
use Scalar::Util         qw(blessed);


sub init($)
{	my ($self, $args) = @_;
	$args->{format}   ||= 'JSON';
	$self->SUPER::init($args);

	$self->{ASJ_json} = $args->{json} || JSON->new->utf8;
	$self;
}

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

sub json() {shift->{ASJ_json}}

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

sub _select($$)
{	my ($self, $args, $params) = @_;

	# select may be called more than once, but do not add wt each time
	# again.
	my $endpoint = $self->endpoint('select', params => $params);
	my $result   = Apache::Solr::Result->new(%$args, params => $params, endpoint => $endpoint, core => $self);
	$self->request($endpoint, $result);

	if(my $dec = $result->decoded)
	{	# JSON uses different names!
		my $r = $dec->{result} = delete $dec->{response};
		$r->{doc} = delete $r->{docs};
	}
	$result;
}

sub _extract($$$)
{	my ($self, $params, $data, $ct) = @_;
	my $endpoint = $self->endpoint('update/extract', params => $params);
	my $result   = Apache::Solr::Result->new(params => $params, endpoint => $endpoint, core => $self);
	$self->request($endpoint, $result, $data, $ct);
	$result;
}

sub _add($$$)
{	my ($self, $docs, $attrs, $params) = @_;
	$attrs   ||= {};
	$params  ||= [];

	my $sv = $self->serverVersion;
	$sv ge '3.1' or error __x"Solr version too old for updates in JSON syntax";

	# We cannot create HASHes with twice the same key in Perl, so cannot
	# produce the syntax for adding multiple documents.  Try to save it.
	delete $attrs->{boost}

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

		error __x"Unable to add more than one doc with JSON interface";
	}
	else
	{	$add = [ map $self->_doc2json($_), @$docs ];
	}

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

sub _doc2json($)
{	my ($self, $this) = @_;
	my %doc;
	foreach my $fieldname ($this->fieldNames)
	{	my @f;
		foreach my $field ($this->fields($fieldname))
		{	my $update = $field->{update} || 'value';
			my $boost  = $field->{boost}  || 1.0;

			undef $boost
				if $boost > 0.9999 && $boost < 1.0001;

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

			  ? +{ boost => $boost, $update => $field->{content} }
			  : +{ $update => $field->{content} };
		}
		# we have to combine multi-fields into ARRAYS
		$doc{$fieldname} = @f > 1 ? \@f : $f[0];
	}

	\%doc;
}

sub _commit($)   { my ($s, $attr) = @_; $s->simpleUpdate(commit   => $attr) }
sub _optimize($) { my ($s, $attr) = @_; $s->simpleUpdate(optimize => $attr) }
sub _delete($$)  { my $self = shift; $self->simpleUpdate(delete   => @_) }
sub _rollback()  { shift->simpleUpdate('rollback') }

sub _terms($)
{	my ($self, $terms) = @_;
	my $endpoint = $self->endpoint('terms', params => $terms);
	my $result   = Apache::Solr::Result->new(params => $terms, endpoint => $endpoint, core => $self);
	$self->request($endpoint, $result);

	my $table = $result->decoded->{terms} || {};
	$table    = {@$table} if ref $table eq 'ARRAY';  # bug in Solr 1.4

	while(my ($field, $terms) = each %$table)
	{	# repack array-of-pairs into array-of-arrays-of-pair

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

		my @terms; 
		push @terms, [shift @pairs, shift @pairs] while @pairs;
		$result->terms($field => \@terms);
	}

	$result;
}

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

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

	if(ref $body && ref $body ne 'SCALAR')
	{	$body_ct ||= 'application/json; charset=utf-8';
		$body      = \$self->json->encode($body);
	}

	# Solr server 3.6.2 seems not to detect the JSON input from the
	# body content, so requires this work-around
	# https://solr.apache.org/guide/6_6/uploading-data-with-index-handlers.html#UploadingDatawithIndexHandlers-JSONUpdateConveniencePaths
	$url =~ s!/update\?!/update/json?!;

	$self->SUPER::request($url, $result, $body, $body_ct);
}

sub decodeResponse($)
{	my ($self, $resp) = @_;

	# At least until Solr 4.0 response ct=text/plain while producing JSON
	my $ct = $resp->content_type;
	$ct =~ m/json/i
		or error __x"Answer from solr server is not json but {type}", type => $ct;

	$self->json->decode($resp->decoded_content || $resp->content);
}


sub simpleUpdate($$;$)
{	my ($self, $command, $attrs, $content) = @_;
	my $sv       = $self->serverVersion;
	$sv ge '3.1' or error __x"Solr version too old for updates in JSON syntax";

	$attrs     ||= {};
	my $params   = [ commit => delete $attrs->{commit} ];
	my $endpoint = $self->endpoint(($sv lt '4.0' ? 'update/json' : 'update'), params => $params);
	my $result = Apache::Solr::Result->new(params => $params, endpoint => $endpoint, core => $self);
	my %params = (%$attrs, (!$content ? () : ref $content eq 'HASH' ? %$content : @$content));
	my $doc    = $self->simpleDocument($command, \%params);
	$self->request($endpoint, $result, $doc);
	$result;
}


sub simpleDocument($;$$)
{	my ($self, $command, $attrs, $content) = @_;
	$attrs   ||= {};
	$content ||= {};
	+{ $command => { %$attrs, %$content } }
}

sub endpoint($@)
{	my ($self, $action, %args) = @_;
	my $params = $args{params} ||= [];

	if(ref $params eq 'HASH') { $params->{wt} ||= 'json' }
	else { $args{params} = [ wt => 'json', @$params ] }

	$self->SUPER::endpoint($action, %args);
}

1;

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

$Data::Dumper::Indent    = 1;
$Data::Dumper::Quotekeys = 0;


use overload
    '""' => 'endpoint'
  , bool => 'success';

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

sub new(@) { my $c = shift; (bless {}, $c)->init({@_}) }
sub init($)
{	my ($self, $args) = @_;

	my $p = $args->{params} || [];
	($p, my $params)      = ref $p eq 'HASH' ? ( +[%$p], $p ) : ($p, +{@$p});
	$self->{ASR_params}   = $p;

	$self->{ASR_endpoint} = $args->{endpoint} or panic;
	$self->{ASR_start}    = time;
	$self->request($args->{request});
	$self->response($args->{response});

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

	weaken $self->{ASR_pages}[0];        # no reference loop!

	if($self->{ASR_core}  = $args->{core}) { weaken $self->{ASR_core} }
	$self->{ASR_next}     = $params->{start} || 0;
	$self->{ASR_seq}      = $args->{sequential} || 0;
	$self->{ASR_fpz}      = $args->{_fpz};
	$self;
}

# replace the pageset with a shared set.
sub _pageset($)
{	$_[0]->{ASR_pages} = $_[1];
	weaken $_[0]->{ASR_pages};           # otherwise memory leak
}

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

sub start()    {shift->{ASR_start}}
sub endpoint() {shift->{ASR_endpoint}}
sub params()   {@{shift->{ASR_params}}}
sub core()     {shift->{ASR_core}}
sub sequential() {shift->{ASR_seq}}

sub request(;$) 
{	my $self = shift;
	@_ && $_[0] or return $self->{ASR_request};
	$self->{ASR_req_out} = time;
	$self->{ASR_request} = shift;
}

sub response(;$) 
{	my $self = shift;
	@_ && $_[0] or return $self->{ASR_response};
	$self->{ASR_resp_in}  = time;
	$self->{ASR_response} = shift;
}

sub decoded(;$) 
{	my $self = shift;
	@_ or return $self->{ASR_decoded};
	$self->{ASR_dec_done} = time;
	$self->{ASR_decoded}  = shift;
}

sub elapse()
{	my $self = shift;
	my $done = $self->{ASR_dec_done} or return;
	$done = $self->{ASR_start};
}


sub success() { my $s = shift; $s->{ASR_success} ||= $s->solrStatus==0 }


sub solrStatus()
{	my $dec  = shift->decoded or return 500;
	$dec->{responseHeader}{status};
}

sub solrQTime()
{	my $dec   = shift->decoded or return;
	my $qtime = $dec->{responseHeader}{QTime};
	defined $qtime ? $qtime/1000 : undef;
}

sub solrError()
{	my $dec  = shift->decoded or return;
	my $err  = $dec->{error} || {};
	my $msg  = $err->{msg}   || '';
	$msg =~ s/\s*$//s;
	length $msg ? $msg : ();
}

sub httpError()
{	my $resp = shift->response or return;
	$resp->status_line;
}

sub serverError()
{	my $resp = shift->response or return;
	$resp->code != 200 or return;
	my $ct   = $resp->content_type;
	$ct eq 'text/html' or return;
	my $body = $resp->decoded_content || $resp->content;
	$body =~ s!.*<body>!!;
	$body =~ s!</body>.*!!;
	$body =~ s!</h[0-6]>|</p>!\n!g;  # cheap reformatter
	$body =~ s!</b>\s*!: !g;
	$body =~ s!<[^>]*>!!gs;
	$body;
}


sub errors()
{	my $self = shift;
	my @errors;
	if(my $h = $self->httpError)   { push @errors, "HTTP error:",   "   $h" }
	if(my $a = $self->serverError) 
	{	$a =~ s/^/   /gm;
		push @errors, "Server error:", $a;
	}
	if(my $s = $self->solrError)   { push @errors, "Solr error:",   "   $s" }
	join "\n", @errors, '';
}

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

sub _responseData()
{	my $dec  = shift->decoded;
	$dec->{result} // $dec->{response};
}

sub nrSelected()
{	my $results = shift->_responseData
		or panic "there are no results (yet)";

	$results->{numFound};
}


sub _docs($)
{	my ($self, $data) = @_;
	my $docs = $data->{doc} // $data->{docs} // [];

	# Decoding XML without schema may give unexpect results
	$docs    = [ $docs ] if ref $docs eq 'HASH'; # when only one result
	$docs;
}

sub selected($%)
{	my ($self, $rank, %options) = @_;
	my $data   = $self->_responseData
		or panic __x"There are no results in the answer";

	# start for next
	$self->{ASR_next} = $rank +1;

	# in this page?
	my $startnr  = $data->{start};
	if($rank >= $startnr)

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


	$rank < $data->{numFound}       # outside answer range
		or return ();
 
	my $pagenr  = $self->selectedPageNr($rank);
	my $page    = $self->selectedPage($pagenr) || $self->selectedPageLoad($pagenr, $self->core);
	$page->selected($rank);
}


sub nextSelected(%)
{	my $self = shift;
	$self->selected($self->{ASR_next}, @_);
}


sub highlighted($)
{	my ($self, $doc) = @_;
	my $rank   = $doc->rank;
	my $pagenr = $self->selectedPageNr($rank);
	my $hl     = $self->selectedPage($pagenr)->decoded->{highlighting}
		or error __x"There is no highlighting information in the result";
	Apache::Solr::Document->fromResult($hl->{$doc->uniqueId}, $rank);
}

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

sub terms($;$)
{	my ($self, $field) = (shift, shift);
	return $self->{ASR_terms}{$field} = shift if @_;

	my $r = $self->{ASR_terms}{$field}
		or error __x"No search for terms on field {field} requested", field => $field;

	$r;
}

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

sub _to_msec($) { sprintf "%.1f", $_[0] * 1000 }

sub showTimings(;$)
{	my ($self, $fh) = @_;
	$fh ||= select;
	my $req     = $self->request;
	my $to      = $req ? $req->uri : '(not set yet)';
	my $start   = localtime $self->{ASR_start};

	$fh->print("endpoint: $to\nstart:    $start\n");

	if($req)
	{	my $reqsize = length($req->as_string);

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

		}
		if(my $error = $self->solrError)
		{	$fh->print("          solr reported error: '$error'\n");
		}
		my $total   = _to_msec($self->{ASR_dec_done} - $self->{ASR_start});
		$fh->print("elapse:   $total ms total\n");
	}
}


sub selectedPageNr($) { my $pz = shift->fullPageSize; $pz ? int(shift() / $pz) : 0 }
sub selectPages()     { @{shift->{ASR_pages}} }


sub selectedPage($)   { my $pages = shift->{ASR_pages}; $pages->[shift()] }


# The reloads page 0, which may have been purged by sequential reading.  Besided,
# the name does not cover its content: it's not the size of the select page but
# the first page.
sub selectedPageSize()
{	my $result = shift->selectedPage(0)->_responseData || {};
	my $docs   = $result->{doc} // $result->{docs};
	ref $docs eq 'HASH'  ? 1 : ref $docs eq 'ARRAY' ? scalar @$docs : 50;
}


sub fullPageSize() { my $self = shift; $self->{ASR_fpz} ||= $self->_calc_page_size }

sub _calc_page_size()
{	my $self = shift;
	my $docs = $self->_docs($self->selectedPage(0)->_responseData);
#warn "CALC PZ=", scalar @$docs;
	scalar @$docs;
}


sub selectedPageLoad($;$)
{	my ($self, $pagenr, $client) = @_;
	$client
		or error __x"Cannot autoload page {nr}, no client provided", nr => $pagenr;

	my $fpz    = $self->fullPageSize;
	my @params = $self->replaceParams( { start => $pagenr * $fpz, rows => $fpz }, $self->params);

	my $seq    = $self->sequential;
	my $page   = $client->select({sequential => $seq, _fpz => $fpz}, @params);
	my $pages  = $self->{ASR_pages};

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


	# purge cached previous pages when in sequential mode
	if($seq && $pagenr != 0)
	{	$pages->[$_] = undef for 0..$pagenr-1;
	}

	$page;
}


sub replaceParams($@)
{	my ($self, $new) = (shift, shift);
	my @out;
	while(@_)
	{	my ($k, $v) = (shift, shift);
		$v = delete $new->{$k} if $new->{$k};
		push @out, $k => $v;
	}
	(@out, %$new);
}

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

$Data::Dumper::Quotekeys = 0;

# See the XML::LibXML::Simple manual page
my @xml_decode_config = (
	ForceArray   => [],
	ContentKey   => '_',
	KeyAttr      => [],
);


sub init($)
{	my ($self, $args) = @_;
	$args->{format} ||= 'XML';

	$self->SUPER::init($args);

	$self->{ASX_simple} = XML::LibXML::Simple->new(@xml_decode_config);
	$self;
}

#---------------
sub xmlsimple() {shift->{ASX_simple}}

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

sub _select($$)
{	my ($self, $args, $params) = @_;
	my $endpoint = $self->endpoint('select', params => $params);
	my $result   = Apache::Solr::Result->new(%$args, params => $params, endpoint => $endpoint, core => $self);
	$self->request($endpoint, $result);
	$result;
}

sub _extract($$$)
{	my ($self, $params, $data, $ct) = @_;
	my $endpoint = $self->endpoint('update/extract', params => $params);
	my $result   = Apache::Solr::Result->new(params => $params, endpoint => $endpoint, core => $self);
	$self->request($endpoint, $result, $data, $ct);
	$result;
}

sub _add($$$)
{	my ($self, $docs, $attrs, $params) = @_;
	$attrs  ||= {};
	$params ||= [];

	my $doc   = XML::LibXML::Document->new('1.0', 'UTF-8');
	my $add   = $doc->createElement('add');
	$add->setAttribute($_ => $attrs->{$_}) for sort keys %$attrs;

	$add->addChild($self->_doc2xml($doc, $_))
		for @$docs;

	$doc->setDocumentElement($add);

	my $endpoint = $self->endpoint('update', params => $params);
	my $result   = Apache::Solr::Result->new(params => $params, endpoint => $endpoint, core => $self);
	$self->request($endpoint, $result, $doc);
	$result;
}

sub _doc2xml($$$)
{	my ($self, $doc, $this) = @_;

	my $node  = $doc->createElement('doc');
	my $boost = $this->boost || 1.0;
	$node->setAttribute(boost => $boost) if $boost != 1.0;

	foreach my $field ($this->fields)
	{	my $fnode = $doc->createElement('field');
		$fnode->setAttribute(name => $field->{name});

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


		$fnode->setAttribute(update => $field->{update})
			if defined $field->{update};

		$fnode->appendText($field->{content});
		$node->addChild($fnode);
	}
	$node;
}

sub _commit($)   { my ($s, $attr) = @_; $s->simpleUpdate(commit   => $attr) }
sub _optimize($) { my ($s, $attr) = @_; $s->simpleUpdate(optimize => $attr) }
sub _delete($$)  { my $self = shift; $self->simpleUpdate(delete   => @_) }
sub _rollback()  { shift->simpleUpdate('rollback') }

sub _terms($)
{	my ($self, $terms) = @_;
	my $endpoint = $self->endpoint('terms', params => $terms);
	my $result   = Apache::Solr::Result->new(params => $terms, endpoint => $endpoint, core => $self);

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

	my $table = $result->decoded->{terms} || {};
	while(my ($field, $terms) = each %$table)
	{	my @terms = map [ $_ => $terms->{$_} ],
			sort {$terms->{$b} <=> $terms->{$a}} keys %$terms;
		$result->terms($field => \@terms);
	}

	$result;
}

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

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

	if(blessed $body && $body->isa('XML::LibXML::Document'))
	{	$body_ct ||= 'text/xml; charset=utf-8';
		$body      = \$body->toString;
	}

	$self->SUPER::request($url, $result, $body, $body_ct);
}

sub _cleanup_parsed($);
sub decodeResponse($)
{	my ($self, $resp) = @_;

	$resp->content_type =~ m/xml/i
		or return undef;

	my $dec = $self->xmlsimple->XMLin(
		$resp->decoded_content || $resp->content,
		parseropts => { huge => 1 },
	);

	_cleanup_parsed $dec;
}

sub _cleanup_parsed($)
{	my $data = shift;

	if(!ref $data) { return $data }
	elsif(ref $data eq 'HASH')   
	{	my %d = %$data;   # start with shallow copy

		# Hash
		if(my $lst = delete $d{lst})
		{	foreach (ref $lst eq 'ARRAY' ? @$lst : $lst)
			{	my $name  = delete $_->{name};

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

	elsif(ref $data eq 'ARRAY')
	{	return [ map _cleanup_parsed($_), @$data ];
	}
	elsif(ref $data eq 'DateTime')
	{	return $data;
	}
	else {panic ref $data || $data}
}


sub simpleUpdate($$;$)
{	my ($self, $command, $attrs, $content) = @_;
	$attrs     ||= {};
	my $params   = [ commit => delete $attrs->{commit} ];
	my $endpoint = $self->endpoint('update', params => $params);
	my $result   = Apache::Solr::Result->new(params => $params, endpoint => $endpoint, core => $self);
	my $doc      = $self->simpleDocument($command, $attrs, $content);
	$self->request($endpoint, $result, $doc);
	$result;
}


sub simpleDocument($;$$)
{	my ($self, $command, $attrs, $content) = @_;
	my $doc  = XML::LibXML::Document->new('1.0', 'UTF-8');
	my $top  = $doc->createElement($command);
	$doc->setDocumentElement($top);

	$attrs ||= {};
	$top->setAttribute($_ => $attrs->{$_}) for sort keys %$attrs;

	if(!defined $content) {}
	elsif(ref $content eq 'HASH' || ref $content eq 'ARRAY')

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

				$top->addChild($node);
			}
		}
	}
	else
	{	$top->appendText($content);
	}
	$doc;
}

sub endpoint($@)
{	my ($self, $action, %args) = @_;
	my $params = $args{params} ||= [];

	if(ref $params eq 'HASH') { $params->{wt} ||= 'xml' }
	else { $args{params} = [ wt => 'xml', @$params ] }

    $self->SUPER::endpoint($action => %args);
}

1;

t/12facet.t view on Meta::CPAN

$Data::Dumper::Indent    = 1;
$Data::Dumper::Quotekeys = 0;

# the server will not be called in this script.
my $server = 'http://localhost:8080/solr';
my $core   = 'my-core';

my $solr = Apache::Solr::XML->new(server => $server, core => $core);
ok(defined $solr, 'instantiated client');

sub decode_xml($)
{   my $xml  = shift;
    my $tree = $solr->xmlsimple->XMLin($xml);
    Apache::Solr::XML::_cleanup_parsed($tree);
}

sub check_get($$$)
{   my ($url, $params, $test) = @_;

    # take the parameters from the url
    $url =~ s/.*\?//;
    my @url = map { split /\=/, $_, 2 } split /\&/, $url;
    s/\+/ /g,s/%([a-zA-Z0-9]{2})/chr hex $1/ge for @url;

    # the order may be important, but ignored for these tests
    my $expanded = $solr->expandSelect(%$params);
#warn Dumper \@url, $expanded;

t/30result.t view on Meta::CPAN

$Data::Dumper::Indent    = 1;
$Data::Dumper::Quotekeys = 0;

# the server will not be called in this script.
my $server = 'http://localhost:8080/solr';
my $core   = 'my-core';

my $solr = Apache::Solr::XML->new(server => $server, core => $core);
ok(defined $solr, 'instantiated client');

sub decode_xml($)
{   my $xml  = shift;
    my $tree = $solr->xmlsimple->XMLin($xml);
    Apache::Solr::XML::_cleanup_parsed($tree);
}

### Results

my $f1 = <<'_RESULT1';
<?xml version="1.0" encoding="UTF-8"?>
<response>

( run in 0.821 second using v1.01-cache-2.11-cpan-65fba6d93b7 )