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         die "need input" unless $self->input;
 134
 135         my $log = $self->_get_logger;
 136         $log->debug("id: $id ds = ",sub { dump($ds) });
 137
 138         my $database = $self->database || $log->logconfess('no database in $self');
 139
 140         my $uri = $self->database . '/' . $self->input . "/$id";
 141         $log->debug("creating $uri");
 142
 143         # filter all tags which have type defined
 144         my $type = $self->type || 'search';
 145         my @tags = grep {
 146                 ref($ds->{$_}) eq 'HASH' && defined( $ds->{$_}->{$type} )
 147         } keys %{ $ds };
 148
 149         $log->debug("tags = ", join(",", @tags));
 150
 151         return unless (@tags);
 152
 153         my $xml = qq{<all>};
 154
 155         $xml .= "<$_>" . $self->$_ . "</$_>" foreach ( 'database', 'input' );
 156
 157         my $data;
 158
 159         foreach my $tag (@tags) {
 160
 161                 my $r = ref $ds->{$tag}->{$type};
 162                 die "tag $tag type $type not ARRAY but '$r' = ",dump( $ds->{$tag}->{$type} ) unless $r eq 'ARRAY';
 163
 164                 my $vals = join(" ", @{ $ds->{$tag}->{$type} });
 165
 166                 next if ! $vals;
 167
 168                 $vals =~ s/($escape_re)/$escape{$1}/gs;
 169                 # BW & EW are our markers for tag boundry
 170                 $xml .= qq{<$tag><![CDATA[BW $vals EW]]></$tag>};
 171
 172                 $self->{stats}->{attr}->{$tag}++;
 173                 $self->{stats}->{input}->{ $self->input }->{$tag}++;
 174
 175                 $data->{$tag} = $vals;
 176         }
 177
 178         # serialize to JSON instead of YAML because we will loose whitespace
 179         $data = to_json($data);
 180         $xml .= qq{<data><![CDATA[$data]]></data>};
 181
 182         $xml .= qq{</all>\n};
 183
 184         my $len = length($xml);
 185
 186         my $fh = $self->{_swish_fh} || die "_swish_fh missing";
 187
 188         print $fh "Path-Name: $uri\nContent-Length: $len\nDocument-Type: XML\n\n$xml" or
 189                 die "can't add $uri: $@\n$xml";
 190
 191         $log->debug( $xml );
 192
 193         return 1;
 194 }
 195
 196 =head2 finish
 197
 198 Dump attributes used on disk
 199
 200 =cut
 201
 202 sub finish {
 203         my $self = shift;
 204         my $log = $self->_get_logger();
 205
 206         my $path = $dir . '/' . $self->{database} . '.yaml';
 207         YAML::DumpFile( $path, $self->{stats} );
 208         $log->info("created  $path ", -s $path, " bytes");
 209         $log->debug( dump( $self->{stats} ) );
 210
 211         close( $self->{_swish_fh} ) || die "can't close index ", $self->index_path, ": $!";
 212 }
 213
 214 =head1 AUTHOR
 215
 216 Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
 217
 218 =head1 COPYRIGHT & LICENSE
 219
 220 Copyright 2004-2009 Dobrica Pavlinusic, All Rights Reserved.
 221
 222 This program is free software; you can redistribute it and/or modify it
 223 under the same terms as Perl itself.
 224
 225 =cut
 226
 227 1;