package WebPAC::Output::SWISH;

use warnings;
use strict;

use lib 'lib';

use base qw/WebPAC::Common Class::Accessor/;
__PACKAGE__->mk_accessors(qw(
	database
	type

	index_path
));

use File::Path qw/make_path/;
use Data::Dump qw/dump/;
use YAML;


=head1 NAME

WebPAC::Output::SWISH - Create swish-e full text index

=cut

our $VERSION = '0.01';

=head1 SYNOPSIS

Create full text index using swish-e indexer from data with
type C<search>.

=head1 FUNCTIONS

=head2 new

 my $out = new WebPAC::Output::SWISH({
	database => 'demo',
 });

Options are:

=over 4

=item database

name of database from which data comes

=back

Name of database will be used to form URI of documents in index.

=cut

our $dir = 'var/swish';

sub init {
	my $self = shift;

	my $log = $self->_get_logger;

	my $database = $self->database || $log->logdie("need database");

	make_path $dir if ! -e $dir;

	my $path = "$dir/$database.conf";

	open(my $conf, '>', $path) || die "can't open $path: $!";

	print $conf <<"DEFAULT_SWISH_CONF";
# swish-e config file for $database

IndexDir stdin

# input file definition
DefaultContents XML*

# indexed metatags
MetaNames xml swishdocpath


#XMLClassAttributes type
UndefinedMetaTags auto
UndefinedXMLAttributes auto

IndexFile $dir/$database

# Croatian ISO-8859-2 characters to unaccented equivalents
#TranslateCharacters ¹©ðÐèÈæÆ¾® ssddcccczz


# disable output
ParserWarnLevel 0
IndexReport 1

DEFAULT_SWISH_CONF

	close($conf) || die "can't write config $path: $!";

	$self->index_path( "$dir/$database" );

	my $swish = "swish-e -S prog -c $path";
	open( $self->{_swish_fh}, '|-', $swish ) || die "can't open pipe to $swish: $!";

	$log->info( "created $path ", -s $path, " bytes for ", $self->index_path );

	$self->{stats} = {};

	$self ? return $self : return undef;
}

=head2

  my $path = $out->index_path;

=head2 add

  $out->add( 42, $ds );

=cut

my %escape = ('<'=>'&lt;', '>'=>'&gt;', '&'=>'&amp;', '"'=>'&quot;');
my $escape_re  = join '|' => keys %escape;

sub add {
	my ($self,$id,$ds) = @_;

	my $log = $self->_get_logger;
	$log->debug("id: $id ds = ",sub { dump($ds) });

	my $database = $self->database || $log->logconfess('no database in $self');

	my $uri = $self->database . "/$id";
	$log->debug("creating $uri");

	# filter all tags which have type defined
	my $type = $self->type || 'search';
	my @tags = grep {
		ref($ds->{$_}) eq 'HASH' && defined( $ds->{$_}->{$type} )
	} keys %{ $ds };

	$log->debug("tags = ", join(",", @tags));

	return unless (@tags);

	my $xml = qq{<xml>};

	foreach my $tag (@tags) {

		my $r = ref $ds->{$tag}->{$type};
		die "tag $tag type $type not ARRAY but '$r' = ",dump( $ds->{$tag}->{$type} ) unless $r eq 'ARRAY';

		my $vals = join(" ", @{ $ds->{$tag}->{$type} });

		next if ! $vals;

		$vals =~ s/($escape_re)/$escape{$1}/gs;
		$xml .= qq{<$tag><![CDATA[$vals]]></$tag>};

		$self->{stats}->{attr}->{$tag}++;
	}

	$xml .= qq{</xml>\n};

	my $len = length($xml);

	my $fh = $self->{_swish_fh} || die "_swish_fh missing";

	print $fh "Path-Name: $uri\nContent-Length: $len\nDocument-Type: XML\n\n$xml" or
		die "can't add $uri: $@\n$xml";

	return 1;
}

=head2 finish

Dump attributes used on disk

=cut

sub finish {
	my $self = shift;
	my $log = $self->_get_logger();

 	my $path = $dir . '/' . $self->{database} . '.yaml';
	YAML::DumpFile( $path, $self->{stats} );
	$log->info("created  $path ", -s $path, " bytes");
	$log->debug( dump( $self->{stats} ) );

	close( $self->{_swish_fh} ) || die "can't close index ", $self->index_path, ": $!";
}

=head1 AUTHOR

Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>

=head1 COPYRIGHT & LICENSE

Copyright 2004-2009 Dobrica Pavlinusic, All Rights Reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;
