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