WebPAC/Output/SWISH.pm

package WebPAC::Output::SWISH;

use warnings;
use strict;

use base qw/WebPAC::Common/;

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 new {
        my $class = shift;
        my $self = {@_};
        bless($self, $class);

        my $log = $self->_get_logger;

        #$log->debug("self: ", sub { dump($self) });

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

        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->{_swish_index_path} = "$dir/$database";

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

        $self->{stats} = {};

        $self ? return $self : return undef;
}

=head2

  my $path = $out->index_path;

=cut

sub index_path { $_[0]->{_swish_index_path} };

=head2 add

Adds one entry to database.

  $out->add(
        id => 42,
        ds => $ds,
        type => 'display',
        text => 'optional text from which snippet is created',
  );

This function will create  entries in index using following URI format:

  C<file:///type/database%20name/000>

Each tag in C<data_structure> with specified C<type> will create one
attribute and corresponding hidden text (used for search).

=cut

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

sub add {
        my $self = shift;

        my $args = {@_};

        my $log = $self->_get_logger;

        my $database = $self->{'database'} || $log->logconfess('no database in $self');
        $log->logconfess('need db in object') unless ($self->{'db'});

        foreach my $p (qw/id ds type/) {
                $log->logdie("need $p") unless ($args->{$p});
        }

        my $type = $args->{'type'};
        my $id = $args->{'id'};

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

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

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

        return unless (@tags);

        my $xml = qq{<xml>};

        foreach my $tag (@tags) {

                my $vals = join(" ", @{ $args->{'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};

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

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

=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;
1	dpavlin	1145	package WebPAC::Output::SWISH;
2
3			use warnings;
4			use strict;
5
6			use base qw/WebPAC::Common/;
7
8			use File::Path qw/make_path/;
9			use Data::Dump qw/dump/;
10			use YAML;
11
12			=head1 NAME
13
14			WebPAC::Output::SWISH - Create swish-e full text index
15
16			=cut
17
18			our $VERSION = '0.01';
19
20			=head1 SYNOPSIS
21
22			Create full text index using swish-e indexer from data with
23			type C<search>.
24
25			=head1 FUNCTIONS
26
27			=head2 new
28
29			my $out = new WebPAC::Output::SWISH(
30			database => 'demo',
31			);
32
33			Options are:
34
35			=over 4
36
37			=item database
38
39			name of database from which data comes
40
41			=back
42
43			Name of database will be used to form URI of documents in index.
44
45			=cut
46
47			our $dir = 'var/swish';
48
49			sub new {
50			my $class = shift;
51			my $self = {@_};
52			bless($self, $class);
53
54			my $log = $self->_get_logger;
55
56			#$log->debug("self: ", sub { dump($self) });
57
58			my $database = $self->{database} \|\| $log->logdie("need database");
59
60			my $path = "$dir/$database.conf";
61
62			open(my $conf, '>', $path) \|\| die "can't open $path: $!";
63
64			print $conf <<"DEFAULT_SWISH_CONF";
65			# swish-e config file for $database
66
67			IndexDir stdin
68
69			# input file definition
70			DefaultContents XML*
71
72			# indexed metatags
73			MetaNames xml swishdocpath
74
75
76			#XMLClassAttributes type
77			UndefinedMetaTags auto
78			UndefinedXMLAttributes auto
79
80			IndexFile $dir/$database
81
82			# Croatian ISO-8859-2 characters to unaccented equivalents
83			TranslateCharacters ¹©ðÐèÈæÆ¾® ssddcccczz
84
85
86			# disable output
87			ParserWarnLevel 0
88			IndexReport 1
89
90			DEFAULT_SWISH_CONF
91
92			close($conf) \|\| die "can't write config $path: $!";
93
94			$self->{_swish_index_path} = "$dir/$database";
95
96			my $swish = "swish-e -S prog -c $path";
97			open( $self->{_swish_fh}, '-\|', $swish ) \|\| die "can't open pipe to $swish: $!";
98
99			$self->{stats} = {};
100
101			$self ? return $self : return undef;
102			}
103
104			=head2
105
106			my $path = $out->index_path;
107
108			=cut
109
110			sub index_path { $_[0]->{_swish_index_path} };
111
112			=head2 add
113
114			Adds one entry to database.
115
116			$out->add(
117			id => 42,
118			ds => $ds,
119			type => 'display',
120			text => 'optional text from which snippet is created',
121			);
122
123			This function will create entries in index using following URI format:
124
125			C<file:///type/database%20name/000>
126
127			Each tag in C<data_structure> with specified C<type> will create one
128			attribute and corresponding hidden text (used for search).
129
130			=cut
131
132			my %escape = ('<'=>'<', '>'=>'>', '&'=>'&', '"'=>'"');
133			my $escape_re = join '\|' => keys %escape;
134
135			sub add {
136			my $self = shift;
137
138			my $args = {@_};
139
140			my $log = $self->_get_logger;
141
142			my $database = $self->{'database'} \|\| $log->logconfess('no database in $self');
143			$log->logconfess('need db in object') unless ($self->{'db'});
144
145			foreach my $p (qw/id ds type/) {
146			$log->logdie("need $p") unless ($args->{$p});
147			}
148
149			my $type = $args->{'type'};
150			my $id = $args->{'id'};
151
152			my $uri = "$database/$id";
153			$log->debug("creating $uri");
154
155			# filter all tags which have type defined
156			my @tags = grep {
157			ref($args->{'ds'}->{$_}) eq 'HASH' && defined( $args->{'ds'}->{$_}->{$type} )
158			} keys %{ $args->{'ds'} };
159
160			$log->debug("tags = ", join(",", @tags));
161
162			return unless (@tags);
163
164			my $xml = qq{<xml>};
165
166			foreach my $tag (@tags) {
167
168			my $vals = join(" ", @{ $args->{'ds'}->{$tag}->{$type} });
169
170			next if ! $vals;
171
172			$vals =~ s/($escape_re)/$escape{$1}/gs;
173			$xml .= qq{<$tag><![CDATA[$vals]]></$tag>};
174
175			$self->{stats}->{attr}->{$tag}++;
176			}
177
178			$xml .= qq{</xml>\n};
179
180			my $len = length($xml);
181
182			my $fh = $self->{_swish_fh};
183
184			print $fh "Path-Name: $uri\nContent-Length: $len\nDocument-Type: XML\n\n$xml";
185			# \|\| die "can't add $uri: $@\n$xml\n";
186
187			return 1;
188			}
189
190			=head2 finish
191
192			Dump attributes used on disk
193
194			=cut
195
196			sub finish {
197			my $self = shift;
198			my $log = $self->_get_logger();
199
200			my $path = $dir . '/' . $self->{database} . '.yaml';
201			YAML::DumpFile( $path, $self->{stats} );
202			$log->info("created $path ", -s $path, " bytes");
203			$log->debug( dump( $self->{stats} ) );
204			}
205
206			=head1 AUTHOR
207
208			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
209
210			=head1 COPYRIGHT & LICENSE
211
212			Copyright 2004-2009 Dobrica Pavlinusic, All Rights Reserved.
213
214			This program is free software; you can redistribute it and/or modify it
215			under the same terms as Perl itself.
216
217			=cut
218
219			1;