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