view release on metacpan or  search on metacpan

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

	$self->process_html($id, $entry->index_data);
	$self->update_key("\x06\%$id", $entry->index_title) if ($entry->can('index_title'));
	$self->update_key("\x07\%$id", $entry->index_keywords) if ($entry->can('index_keywords'));
	$self->update_key("\x08\%$id", $entry->index_description) if ($entry->can('index_description'));
	if ($self->extended) {
		my @attributes = @{$self->attribute_list};
		splice(@attributes, 0, 8);
		foreach my $attribute (@attributes) {
			my $value = undef;
			if ($entry->can("index_$attribute")) {
				eval('$value = $entry->index_' . $attribute);
				$self->set_error($@) if ($@);
				$self->check_error;
			} elsif (exists($entry->{$attribute})) {
				$value = $entry->{$attribute};
			}
			if ($entry->can("handle_$attribute")) {
				eval('$entry->handle_' . $attribute . '($id, $value)');
				$self->set_error($@) if ($@);
				$self->check_error;
			} else {
				if ($self->maps->{$attribute}) {
					$self->index_map($attribute, $id, [token_parse(lc($value))]);
				} else {
					$self->update_key($self->attributes->{$attribute} . "\%$id", $value);
				}
			}
		}
	}
	$self->update_key($id, $name);
	$self->update_key("\x00%" . $name, $id);
	my $result = 0;
	$self->db->db_get("\xff%greatest_id", my $greatest_id);
	$self->update_key("\xff%greatest_id", $id) if ($id > $greatest_id);
	if ($result) {
		$self->set_error("Failed to store greatest ID: $id");
		$self->check_error;
	}

	if ($self->current_transaction) {
		if ($self->error) {
			unless ($self->quiet) {
				warn join ("\n", "Errors occurred in update of $name => $id:", $self->error, "Aborting transaction...");
			}
			$self->current_transaction->txn_abort;
		} else {
			$self->current_transaction->txn_commit;
		}
		$self->{'current_transaction'} = undef;
	}

	$self->close_db;

	return "Update of entry $id " . ($self->error ? "unsuccessful." : "successful.");
}

sub purge_entry {
	my ($self, $entry) = @_;
	my $id = undef;
	my $found_entry = undef;
	my $not_entry = $self->db->db_get("\x00%$entry", $found_entry);
	if ($not_entry) {
		$id = $entry;
		$self->db->db_get($entry, $found_entry);
		$entry = $found_entry;
	} else {
		$id = $found_entry;
	}
	#warn "$id and $entry";
	unless ($id and $entry) {
		return "Entry not found to purge: $entry";
		return 1;
	}
	$self->set_error("purge_entry called without write access") unless ($self->status eq 'RW');
	foreach my $attribute (@{$self->attribute_list}) {
		next if ($attribute eq 'reverse');
		#warn "purging $attribute";
		if ($self->maps->{$attribute}) {
			$self->purge_map($attribute, $id) unless ($self->dirty) && $self->set_error("failed to purge map $attribute");
		} else {
			$self->delete_key($self->attributes->{$attribute} . "%$id") && $self->set_error("failed to purge key $attribute");
		}
	}
	$self->db->db_del($id) && $self->set_error("failed to purge ID $id");
	$self->db->db_del("\x00%$entry") && $self->set_error("failed to purge entry $entry");
	my $errors = $self->error;
	return "Entry (BerkeleyDB ID# $id) successfully purged" unless ($errors);
	return "Entry (BerkeleyDB ID# $id) failed to be purged: " . join("\n", $self->error) . "\n";
}

=pod

=item (hashref) C<entry_by_name> (scalar)

Given the value of an B<name> attribute, returns a hashref of all the regular
attributes stored for a given entry.

=cut

sub entry_by_name {
	my ($self, $name) = @_;
	my $id = $self->get_id($name);
	return $self->get_entry($id);
}

sub get_entry {
	#note - Call get_entry with an ID ONLY.  No names
	my ($self, $id, $params) = @_;
	$params = {} unless (ref($params) eq 'HASH');
	my $failed = $self->db->db_get($id, my $name);
	return {} if ($failed);
	my %entry = (id => $id, name => $name);
	my @attributes = @{$self->attribute_list};
	my %skip = map {$_ => 1} (@{$params->{'skip'} || []}, @{$self->map_list}, 'name', 'id');
	@attributes = grep {!$skip{$_}} @attributes;
	if ($params->{'limit'}) {
		my %limit = map {$_ => 1} @{$params->{'limit'}};
		@attributes = grep {$limit{$_}} @attributes;
	}
	if ($params->{'require'}) {
		my %unique = ();
		@attributes = grep {$unique{$_}++ == 0} (@attributes, @{$params->{'require'}});

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

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

sub purge_map {
	my ($self, $attribute_name, $id) = @_;
	my $debug = $self->debug;
	$debug = 1 if ($self->{'runtime_flags'}->{'debug'});
	my $attribute = $self->attributes->{$attribute_name};
	my $rev_attribute = $self->attributes->{"_$attribute_name"};
	my $reverse_index = '';
	my $reversemap_notfound = 1;#by default, don't search for a reversemap unless it's supposed to have one.
	$reversemap_notfound = $self->db->db_get("$rev_attribute\%$id", $reverse_index) if ($self->reversemaps);
	my @updates = ();
	if (not($reversemap_notfound)) {
		$debug && warn ("Found reverse index for map $attribute_name.  Will purge based on that value.");
		foreach my $entry (split "\x00", $reverse_index) {
			#warn "purging $id from $entry";
			my $result = $self->db->db_get("$attribute\%$entry", my $current);
			if ($result) {
				$debug && warn "Reverse index for $attribute_name has a corrupt entry: $entry.  Will do a complete purge.";
				$reversemap_notfound = 1;
				$reversemap_notfound = 0 if ($attribute_name) eq 'word';
				last;
			}
			my(%entries) = unpack("n*", $current);
			#warn "$entry has " . scalar(keys(%entries)) . " documents";
			my $value = undef;
			foreach my $item (keys %entries) {
				#warn "$entry has doc $item";
				next if ($item eq $id);
				$value .= pack "n", $item;
				$value .= pack "n", $entries{$item};
			}
			push (@updates, "$attribute\%$entry", $value);
		}
		$self->db->db_del("$rev_attribute\%$id")  && $self->set_error("Could not remove reversemap for $attribute_name on id $id");
	}
	if ($reversemap_notfound) {
		$debug && $self->reversemaps && warn ("No reverse index for map $attribute_name.  Doing a full purge of $id from the map.");
		my ($key, $current, $removed) = ();
		my $cursor = $self->db->db_cursor;
		unless ($cursor) {
			$self->read_db;
			$cursor = $self->db->db_cursor;
			unless ($cursor) {
				warn 'Failed to obtain DB Cursor.  Aborting purge_map()';
				return 1;
			}