#!/usr/bin/perl use warnings; use strict; use CGI qw/:standard/; use CGI::Carp qw/fatalsToBrowser/; use File::Slurp; use YAML; use Data::Page; use Data::Dump qw/dump/; use SWISH::API; use JSON; use Text::Unaccent::PurePerl qw/unac_string/; use HTML::FillInForm::Lite; use Encode; my $range_around = 5; my @entries_per_page = ( 30, 50, 100, 500 ); my $debug = param('debug'); print header( -charset => 'utf-8', ); sub dump_yaml { my $name = shift; print qq|
$name
|, YAML::Dump( @_ ), qq|
| if $debug; } sub show_pager { my ($pager) = @_; my @show_pages; my $after_current = 0; if ( $pager->current_page <= $range_around + 2 ) { @show_pages = ( $pager->first_page .. $pager->current_page ); $after_current = $range_around - $pager->current_page; } else { @show_pages = ( $pager->first_page, '', $pager->current_page - $range_around .. $pager->current_page ); } if ( $pager->current_page + $after_current + $range_around + 1 >= $pager->last_page ) { push @show_pages, ( $pager->current_page + 1 .. $pager->last_page ); } else { push @show_pages, ( $pager->current_page + 1 .. $pager->current_page + $after_current + $range_around, '', $pager->last_page ); } # dump_yaml( 'show_pages', \@show_pages ); return '' unless $#show_pages; my ( $prev, $next ) = ( '<<', '>>' ); sub li_a_href { my ( $page, $label, $attr ) = @_; param( 'current_page', $page ); my $url = self_url( -query => 1 ); $attr ||= ''; $label ||= $page; qq|$label|; } return $pager->previous_page ? li_a_href( $pager->previous_page, $prev ) : qq|| , ( map { if ( $_ eq $pager->current_page ) { qq|
  • $_
  • |; } elsif ( $_ eq '' ) { qq||; } else { li_a_href( $_ ); } } @show_pages ) , $pager->next_page ? li_a_href( $pager->next_page, $next ) : qq|| ; } my $path = $ENV{PATH_INFO} || 'ecas'; $path =~ s{^/+}{}; $path =~ s{/+$}{}; my $dir = $0; $dir =~ s{/[^/]+.cgi}{}; dump_yaml( 'dir', $dir ); my $config = YAML::LoadFile( "$dir/$path/config.yml" ); my $database = (keys %{ $config->{databases} })[0]; die "$database not in $path" unless $path =~ m{\Q$database\E}; my $html_markup = "$dir/$path/html.pm"; my $html_markup_skip; if ( -e $html_markup ) { require $html_markup; $html_markup = $database . '::html'; } else { undef $html_markup; } my $stats; { my $path = "$dir/../var/swish/$database.yaml"; $stats = YAML::LoadFile( $path ); dump_yaml( "stats $path", $stats ); } my $db = $config->{databases}->{$database}; sub read_config_txt { my ( $file ) = @_; my $input; my $path ="$dir/$path/$path-$file.txt"; if ( ! -e $path ) { warn "missing $path"; return; } foreach ( split(/[\n\r]+/, read_file( $path ) ) ) { my ( $val,$label ) = split(/\s*\t\s*/,$_,2); push @{ $input->{ '-values' } }, $val; $input->{ '-labels' }->{$val} = $label; } return $input; } my $attr_labels = read_config_txt 'labels'; my $attr_operators = read_config_txt 'operators'; my @attr = @{ $attr_labels->{'-values'} } if $attr_labels; @attr = keys %{ $stats->{attr} } unless @attr; warn dump( $attr_labels, $attr_operators ); my $only_input; my $inputs_available = 0; foreach ( @{ $db->{input} } ) { my $input = $_->{name} || die "no name in ",dump( $_ ); next unless defined $stats->{input}->{$input}; # skip inputs without data if ( ! $only_input->{'-labels'}->{$input} ) { push @{ $only_input->{'-values'} }, $input; $only_input->{'-labels'}->{$input} = $_->{description} || $input; $inputs_available++; } } warn "## only_input = ", dump( $only_input ); my @style = ( '../../style.css' ); push @style, "../../$path/$path.css" if -e "$dir/$path/$path.css"; dump_yaml( 'style', \@style ); sub search_form { my $form_html = "$dir/$path/$path-search.html"; if ( -e $form_html ) { my $html = read_file( $form_html ); my $q = CGI->new(); my $h = HTML::FillInForm::Lite->new(); return $h->fill(\$html, $q); } qq||, start_form( -action => self_url( query => 0 ) ), checkbox_group( -name => 'attr', %$attr_labels, # -linebreak => 0, ), textfield( -name => 'search' ), $attr_operators ? popup_menu( -name => 'attr_operator', %$attr_operators ) : '', submit( -value => 'Search' ), # hidden( -name => 'entries_per_page', -default => $entries_per_page ), popup_menu( -name => 'entries_per_page', -values => [ @entries_per_page ], -title => 'entries per page' ), # we need current_page fixed at 1 so that every submit through form will reset it qq||, checkbox( -name => 'debug', -default => 0 ), # FIXME hidden? qq|
    |, $inputs_available > 1 ? h2( 'Select input' ) . checkbox_group( -name => 'only_input', %$only_input, -linebreak=> 'true', ) : '', qq|
    |, end_form, ; } print start_html( -title => $db->{name}, -style => [ @style ], ), h1( $db->{name} ), qq|
    |, $db->{description}, qq|
    |, ; if ( my $search = param('search') ) { $search = unac_string( Encode::decode('utf-8',$search) ); print qq|
    |; my $swish = SWISH::API->new( "$dir/../var/swish/$database" ); $swish->abort_last_error if $swish->Error; my @search = (); my @attrs = param('attr'); my $op = param('attr_operator'); if ( $search =~ m{(=|"|\bAND\b|\bOR\b)} ) { push @search, $search; } elsif ( @attrs ) { $op ||= 'Q*'; my @or; foreach my $attr ( @attrs ) { my $v = $search; $v =~ s/^\s+//; warn "-- v: $v\n"; sub rewrite { my ( $attr, $whitespace, $v ) = @_; warn "## filter $op $whitespace $v\n"; my $template = $op; $template =~ s{Q}{$v}; $whitespace = " AND " if $whitespace; # don't return -* &* and other non-word characters return '' if $template =~ m/^\W\*$/ || $template =~ m/\band\b/i; return $whitespace . $attr . '="' . $template . '"'; ; }; if ( $op =~ m{\s} ) { my $template = $op; $template =~ s{Q}{$v}; $v = $attr . '="' . $template . '"'; } else { $v =~ s{(\s*)(\S+)}{rewrite($attr,$1,$2)}ge; } push @or, $v; } push @search, '(' . join(') OR (', @or) . ')'; } else { push @search, "all=\"$search\""; } my $q = '(' . join(') AND (', @search) . ')'; my @only_input = param('only_input'); $q .= ' AND ((' . join(') OR (', map { "input=\"$_\"" } @only_input) . '))' if @only_input; warn "# query: $q\n"; my $search_obj = $swish->new_search_object; if ( my $sort = param('sort') ) { $search_obj->set_sort( $sort ); } my $swish_results = $search_obj->execute( $q ); dump_yaml( 'swish_results', $swish_results ); my $pager = Data::Page->new; $pager->$_( param($_) ) foreach ( qw/entries_per_page current_page/ ); $pager->total_entries( $swish_results->hits ); dump_yaml( 'pager', $pager ); $swish_results->seek_result( $pager->first - 1 ); if ( ! $pager->total_entries ) { my $no_results = 'No results for search %s'; $no_results = $swish->error_string . '
    %s' if $swish->error; printf qq|
    $no_results
    \n\n|, $q; } else { my $results = "%d results for search %s showing results %d - %d"; printf qq|
    $results
    \n\n|, $pager->total_entries, $q, $pager->first, $pager->last; my $pager_html = join("\n", show_pager( $pager )); print qq|\n\n| if $pager_html; my $nr = $pager->first; print qq|
      \n|; my $limit = $pager->entries_on_this_page; my $nr = 1; while ( my $result = $swish_results->next_result ) { my $data = $result->property('data'); dump_yaml( 'data', $data ); # FIXME if we produce valid json we shouldn't need eval here! eval { $data = from_json( $data, {utf8 => 1} ); }; if ( $@ ) { warn "ERROR: $@ from ",dump( $data ); next; } my $li_class = ''; $li_class = qq| class="z"| if $nr % 2 == 0; print qq||; foreach my $attr ( @attr ) { next unless defined $data->{$attr}; my $v = $data->{$attr}; if ( $html_markup && ! $html_markup_skip->{$attr} ) { eval "\$v = $html_markup->$attr( \$v, \$data );"; if ( $@ ) { warn "disable html markup for $attr: $@"; $html_markup_skip->{$attr} = $@; } } else { $v =~ s{(http://\S+)}{$1}; } my $label = $attr_labels->{'-labels'}->{$attr} || $attr; print qq|
      $v
      \n|; } print qq|\n|; last if $nr++ == $pager->last; } print qq|
    \n\n|; print qq|\n\n| if $pager_html; } print qq|
    |; dump_yaml( 'pager', $pager ); } print search_form; dump_yaml( "config databases $database", $db ); dump_yaml( 'html_markup_skip', $html_markup_skip ); print end_html;