git.rot13.org Git - webpac2/blob - lib/WebPAC/Output/SWISH.pm

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