view release on metacpan or  search on metacpan

Wyrd/Services/Index.pm  view on Meta::CPAN

			my $index = tie (%index, 'BerkeleyDB::Btree', -Filename => $self->file, -Flags => DB_CREATE, -Env => $env, -Mode => 0660);
			$error = 1 unless($index);
			$errors .= $env->status . "\n" if ($error);
			$index->db_close if ($index);
			$index = undef;
			%index = ();
			if ($self->bigfile) {
				my %bindex = ();
				my $bindex = tie %bindex, 'BerkeleyDB::Btree', -Filename => $self->bigfilename, -Flags => DB_CREATE, -Env => $env, -Mode => 0660;
				$self->{'db_big'} = $bindex;
				$error = 1 unless ($bindex);
				$errors .= $env->status . "\n" if ($error);
				$bindex->db_close if ($bindex);
				$bindex = undef;
				%bindex = ();
			}
			die ("recovery of database failed for both DB_RECOVER and DB_RECOVER_FATAL: $errors") if ($error);
			$self->check_error;
		}
	}
}

sub close_db {
	my ($self) = @_;
	my $index = $self->{'db'};
	if (ref($index) and UNIVERSAL::isa($index, 'Apache::Wyrd::Services::Index')) {
		$index->db_close;
		untie %{$self->{'db'}};
		$self->{'db'} = undef;
		delete ($self->{'status'}); #close the DB ref
		$self->{'status'} = undef;
	}
	$index = $self->{'db_big'};
	if (ref($index) and UNIVERSAL::isa($index, 'Apache::Wyrd::Services::Index')) {
		$index->db_close;
		untie %{$self->{'db_big'}};
		$self->{'db_big'} = undef;
		delete ($self->{'status'}); #close the DB ref
		$self->{'status'} = undef;
	}
	my $env = $self->{'env'};
	if (ref($env) and UNIVERSAL::isa($env, 'BerkeleyDB::Env')) {
		$self->{'env'} = undef;
	}
	undef $index;
	undef $env;
	return;
}

=pod

=item (scalar) C<update_entry> (Apache::Wyrd::Interfaces::Indexable ref)

Called by an indexable object, passing itself as the argument, in order to
update it's entry in the index.  This method calls C<index_foo> for every
attribute B<foo> in the index, storing that value under the attribute entry for
that object.  The function always returns a message about the process.

update_entry will always check index_timestamp and index_digest.  If the stored
value and the returned value agree on either attribute, the index will not be
updated.  This behavior can be overridden by returning a true value from method
C<force_update>.

Index will also check for an C<index_runtime_flags> method and call it to
determine if the indexed object is attempting to modify the behavior of the
update during the process of updating for debugging purposes.  Currently, it
recognizes the following flags:

=over

=item debug/nodebug

Turn on debugging messages for the course of this update, even if debug is
not specified in the arguments to C<new>.

=item nodata

Avoid processing, word-mapping, and storing the data attribute.

=back

=cut

#attributes - integer=name (self_path), 0=reverse, 1=timestamp, 2=digest, 3=data, 4=word, 5=count, 6=title, 7=keywords, 8=description
sub update_entry {
	my ($self, $entry) = @_;
	$self->set_error = "Index entries must be objects " unless (ref($entry));
	#localize debug value so that the entry can modify it.
	my $debug = $self->debug;
	$self->{'runtime_flags'} = {};
	if (UNIVERSAL::can($entry, 'index_runtime_flags')) {
		map {$self->{'runtime_flags'}->{$_} => 1} token_parse($entry->index_runtime_flags);
		$debug = 1 if ($self->{'runtime_flags'}->{'debug'});
		$debug = 0 if ($self->{'runtime_flags'}->{'nodebug'});
	}
	foreach my $function (qw/no_index index_name index_timestamp index_digest index_data/) {
		$self->set_error("Index entries must implement the method $function\(\)") unless ($entry->can($function));
	}
	my $name = $entry->index_name;
	$self->set_error("Index entries must return non-null for method index_name()") unless ($name);
	$self->check_error;
	$self->set_error("<DELETED> is an invalid name for index entries ") if ($name eq '<DELETED>');
	$self->set_error($name . " is an invalid name for index entries ") if ($name =~ /^.%/s);
	$self->check_error;
	my $index = $self->read_db;
	my $null = undef;#used for DB checks where no value needs be returned
	if ($entry->no_index) {
		if ($index->db_get("\x00%" . $name, $null)) {
			#if key is not found
			return "yes to no_index and not indexed.";
		}
		$index = $self->write_db;
		my $result = $self->purge_entry($name);
		$self->close_db;
		return $result;
	}
	my ($id, $id_is_new) = $self->get_id($name);
	$debug && warn $name . " is new" if ($id_is_new);
	unless ($entry->force_update) {
		$index->db_get("\x01\%$id", my $timestamp);
		$debug && warn "Comparing timestamps: $timestamp <-> " . $entry->index_timestamp . " for " . $name;

Wyrd/Services/Index.pm  view on Meta::CPAN

	$result = $self->db->db_get($key, $value);
	return undef if (($result eq 'DB_NOTFOUND') or !$result);
	$self->set_error("Could not get key: " . $result);
	$self->check_error;
	return;
}

sub update_key {
	my ($self, $key, $value) = @_;
	my $result = $self->db->db_put($key, $value);
	return undef unless ($result);
	$self->recover_db;
	$self->write_db;
	$result = $self->db->db_put($key, $value);
	return undef unless ($result);
	$self->set_error("Could not set key: " . $result);
	$self->check_error;
	return;
}

sub delete_key {
	my ($self, $key) = @_;
	my $result = $self->db->db_del($key);
	return undef if (($result == DB_NOTFOUND) or !$result);
	$self->recover_db;
	$self->write_db;
	$result = $self->db->db_del($key);
	return undef if (($result == DB_NOTFOUND) or !$result);
	$self->set_error("Could not delete key: " . $result);
	$self->check_error;
}

sub process_html {
	my ($self, $id, $data) = @_;

	return undef if ($self->{'runtime_flags'}->{'no_data'});

	#Remove all punctuation noise from the data and turn all control characters
	#and unicode into entities
	$data = $self->clean_html($data);

	#if we're doing bigfiles, we get a chance to override the re-indexing
	#of large swaths of data if there has been no change to the html of the
	#indexed object
	if ($self->bigfile and length($data) >= 2048) {
		$self->db->db_get("\x03\%$id", my $old_key);
		$old_key =~ s/^\x00://;
		my $current_key = sha1_hex($data);
		if ($current_key ne $old_key) {
			$self->db_big->db_put($current_key, $data);
			my $wordcount = $self->index_words($id, $data);
			$self->update_key("\x03\%$id", "\x00:$current_key");
			$self->update_key("\x05\%$id", $wordcount);
		}
		return;
	}

	$self->update_key("\x03\%$id", $data);
	my $wordcount = $self->index_words($id, $data);
	$self->update_key("\x05\%$id", $wordcount);
	#warn "\x03\%$id updated to $data";
	return;
}

sub extract_html {
	my ($self, $id) = @_;
	$self->db->db_get("\x03\%$id", my $data);
	if ($data =~ s/^\x00:(.+)//) {
		$self->db_big->db_get($1, $data);
	}
	return $data;
}

sub index_map {
	my ($self, $attribute_name, $id, $data) = @_;

	use Encode qw(_utf8_off);
	_utf8_off($data);
	#warn "mapping $id - $attribute : " . join (':', @$data);
	my $attribute = $self->attributes->{$attribute_name};
	my (%unique, $item, @items) = (); # for unique-ifying word list
	#remove duplicates if necessary
	if (ref($data) eq 'ARRAY') {
		@items = grep { $unique{$_}++ == 0 } @$data;
	} elsif (ref($data) eq 'HASH') {
		%unique = %$data;
		@items = keys(%unique);
	} else {
		#not sure why you'd want to do this, but hey.
		@items = ($data);
	}
	if ($attribute_name eq 'word') {
		@items = grep {length($_) >= $self->wordmin} @items;
	}
	# For each item, add id to map
	foreach my $item (sort @items) {

		#This actually does happen, strangely enough.
		unless ($item or ($item =~ /^0+$/o)) {
			warn 'null item here';
			warn 'but defined' if (defined($item));
		}
		my $value = undef;
		my $not_found = $self->db->db_get("$attribute\%$item", my $data);
		my(%entries) = ();
		%entries = unpack("n*", $data) unless ($not_found);
		$entries{$id} = $unique{$item};
		foreach my $item (keys %entries) {
			$value .= pack "n", $item;
			$value .= pack "n", $entries{$item};
		}
		#warn($self->translate_packed($attribute) . "\%$item: " . $self->translate_packed($value));
		$self->update_key("$attribute\%$item", $value);
	}
	if ($self->reversemaps) {
		my $rev_attribute = $self->attributes->{"_$attribute_name"};
		$self->update_key("$rev_attribute\%$id", join("\x00", @items));
	}
	return;
}