Open-ILS/src/perlmods/lib/OpenILS/WWW/EGCatLoader/Browse.pm

   1 package OpenILS::WWW::EGCatLoader;
   2
   3 use strict;
   4 use warnings;
   5
   6 use OpenSRF::Utils::Logger qw/$logger/;
   7 use OpenILS::Utils::CStoreEditor qw/:funcs/;
   8 use OpenILS::Utils::Fieldmapper;
   9 use OpenILS::Utils::Normalize qw/search_normalize/;
  10 use OpenILS::Application::AppUtils;
  11 use OpenSRF::Utils::JSON;
  12 use OpenSRF::Utils::Cache;
  13 use OpenSRF::Utils::SettingsClient;
  14
  15 use Digest::MD5 qw/md5_hex/;
  16 use Apache2::Const -compile => qw/OK/;
  17 use MARC::Record;
  18 use List::Util qw/first/;
  19 #use Data::Dumper;
  20 #$Data::Dumper::Indent = 0;
  21
  22 my $U = 'OpenILS::Application::AppUtils';
  23 my $browse_cache;
  24 my $browse_timeout;
  25
  26 # Plain procedural functions start here.
  27 #
  28 sub _init_browse_cache {
  29     if (not defined $browse_cache) {
  30         my $conf = new OpenSRF::Utils::SettingsClient;
  31
  32         $browse_timeout = $conf->config_value(
  33             "apps", "open-ils.search", "app_settings", "cache_timeout"
  34         ) || 300;
  35         $browse_cache = new OpenSRF::Utils::Cache("global");
  36     }
  37 }
  38
  39 sub _get_authority_heading {
  40     my ($field, $sf_lookup) = @_;
  41
  42     return join(
  43         " ",
  44         map { $_->[1] } grep { $sf_lookup->{$_->[0]} } $field->subfields
  45     );
  46 }
  47
  48 # Object methods start here.
  49 #
  50
  51 # Returns cache key and a list of parameters for DB proc metabib.browse().
  52 sub prepare_browse_parameters {
  53     my ($self) = @_;
  54
  55     no warnings 'uninitialized';
  56
  57     # XXX TODO add config.global_flag rows for browse limit-limit ?
  58
  59     my @params = (
  60         scalar($self->cgi->param('qtype')),
  61         scalar($self->cgi->param('bterm')),
  62         $self->ctx->{copy_location_group_org} ||
  63             $self->ctx->{aou_tree}->()->id,
  64         $self->ctx->{copy_location_group},
  65         $self->ctx->{is_staff} ? 't' : 'f',
  66         scalar($self->cgi->param('bpivot')),
  67         int(
  68             $self->cgi->param('blimit') ||
  69             $self->ctx->{opac_hits_per_page} || 10
  70         )
  71     );
  72
  73     return (
  74         "oils_browse_" . md5_hex(OpenSRF::Utils::JSON->perl2JSON(\@params)),
  75         @params
  76     );
  77 }
  78
  79 # Break out any Public General Notes (field 680) for display. These are
  80 # sometimes (erroneously?) called "scope notes." I say erroneously,
  81 # tentatively, because LoC doesn't seem to document a "scope notes"
  82 # field for authority records, while it does so for classification
  83 # records, which are something else. But I am not a librarian.
  84 sub extract_public_general_notes {
  85     my ($self, $record, $row) = @_;
  86
  87     # Make a list of strings, each string being a concatentation of any
  88     # subfields 'i', '5', or 'a' from one field 680, in order of appearance.
  89     $row->{notes} = [
  90         map {
  91             join(
  92                 " ",
  93                 map { $_->[1] } grep { $_->[0] =~ /[i5a]/ } $_->subfields
  94             )
  95         } $record->field('680')
  96     ];
  97 }
  98
  99 sub find_authority_headings_and_notes {
 100     my ($self, $row) = @_;
 101
 102     my $acsaf_table =
 103         $self->ctx->{get_authority_fields}->($row->{control_set});
 104
 105     $row->{headings} = [];
 106
 107     my $record;
 108     eval {
 109         $record = new_from_xml MARC::Record($row->{marc});
 110     };
 111     if ($@) {
 112         $logger->warn("Problem with MARC from authority record #" .
 113             $row->{id} . ": $@");
 114         return $row;    # We're called in map(), so we must move on without
 115                         # a fuss.
 116     }
 117
 118     $self->extract_public_general_notes($record, $row);
 119
 120     # By applying grep in this way, we get acsaf objects that *have* and
 121     # therefore *aren't* main entries, which is what we want.
 122     foreach my $acsaf (grep { $_->main_entry } values(%$acsaf_table)) {
 123         my @fields = $record->field($acsaf->tag);
 124         my %sf_lookup = map { $_ => 1 } split("", $acsaf->display_sf_list);
 125         my @headings;
 126
 127         foreach my $field (@fields) {
 128             my $h = { heading => _get_authority_heading($field, \%sf_lookup) };
 129
 130             # XXX I was getting "target" from authority.authority_linking, but
 131             # that makes no sense: that table can only tell you that one
 132             # authority record as a whole points at another record.  It does
 133             # not record when a specific *field* in one authority record
 134             # points to another record (not that it makes much sense for
 135             # one authority record to have links to multiple others, but I can't
 136             # say there definitely aren't cases for that).
 137             $h->{target} = $2
 138                 if ($field->subfield('0') || "") =~ /(^|\))(\d+)$/;
 139
 140             push @headings, $h;
 141         }
 142
 143         push @{$row->{headings}}, {$acsaf->id => \@headings} if @headings;
 144     }
 145
 146     return $row;
 147 }
 148
 149 sub map_authority_headings_to_results {
 150     my ($self, $linked, $results, $auth_ids) = @_;
 151
 152     # Use the linked authority records' control sets to find and pick
 153     # out non-main-entry headings. Build the headings and make a
 154     # combined data structure for the template's use.
 155     my %linked_headings_by_auth_id = map {
 156         $_->{id} => $self->find_authority_headings_and_notes($_)
 157     } @$linked;
 158
 159     # Graft this authority heading data onto our main result set at the
 160     # "authorities" column.
 161     foreach my $row (@$results) {
 162         $row->{authorities} = [
 163             map { $linked_headings_by_auth_id{$_} } @{$row->{authorities}}
 164         ];
 165     }
 166
 167     # Get linked-bib counts for each of those authorities, and put THAT
 168     # information into place in the data structure.
 169     my $counts = $self->editor->json_query({
 170         select => {
 171             abl => [
 172                 {column => "id", transform => "count",
 173                     alias => "count", aggregate => 1},
 174                 "authority"
 175             ]
 176         },
 177         from => {abl => {}},
 178         where => {
 179             "+abl" => {
 180                 authority => [
 181                     @$auth_ids,
 182                     $U->unique_unnested_numbers(map { $_->{target} } @$linked)
 183                 ]
 184             }
 185         }
 186     }) or return;
 187
 188     my %auth_counts = map { $_->{authority} => $_->{count} } @$counts;
 189
 190     # Soooo nesty!  We look for places where we'll need a count of bibs
 191     # linked to an authority record, and put it there for the template to find.
 192     for my $row (@$results) {
 193         for my $auth (@{$row->{authorities}}) {
 194             if ($auth->{headings}) {
 195                 for my $outer_heading (@{$auth->{headings}}) {
 196                     for my $heading_blob (@{(values %$outer_heading)[0]}) {
 197                         if ($heading_blob->{target}) {
 198                             $heading_blob->{target_count} =
 199                                 $auth_counts{$heading_blob->{target}};
 200                         }
 201                     }
 202                 }
 203             }
 204         }
 205     }
 206 }
 207
 208 # flesh_browse_results() attaches data from authority records. It
 209 # changes $results and returns 1 for success, undef for failure (in which
 210 # case $self->editor->event should always point to the reason for failure).
 211 # $results must be an arrayref of result rows from the DB's metabib.browse()
 212 sub flesh_browse_results {
 213     my ($self, $results) = @_;
 214
 215     # Turn comma-seprated strings of numbers in "authorities" column
 216     # into arrays.
 217     $_->{authorities} = [split /,/, $_->{authorities}] foreach @$results;
 218
 219     # Group them in one arrray, not worrying about dupes because we're about
 220     # to use them in an IN () comparison in a SQL query.
 221     my @auth_ids = map { @{$_->{authorities}} } @$results;
 222
 223     if (@auth_ids) {
 224         # Get all linked authority records themselves
 225         my $linked = $self->editor->json_query({
 226             select => {
 227                 are => [qw/id marc control_set/],
 228                 aalink => [{column => "target", transform => "array_agg",
 229                     aggregate => 1}]
 230             },
 231             from => {
 232                 are => {
 233                     aalink => {
 234                         type => "left",
 235                         fkey => "id", field => "source"
 236                     }
 237                 }
 238             },
 239             where => {"+are" => {id => \@auth_ids}}
 240         }) or return;
 241
 242         $self->map_authority_headings_to_results($linked, $results, \@auth_ids);
 243     }
 244
 245     return 1;
 246 }
 247
 248 sub load_browse_impl {
 249     my ($self, @params) = @_;
 250
 251     my $results = $self->editor->json_query({
 252         from => [ "metabib.browse", @params ]
 253     });
 254
 255     if (not $results) {  # DB error, not empty result set.
 256         $logger->warn(
 257             "error in browse (direct): " . $self->editor->event->{textcode}
 258         );
 259         $self->ctx->{browse_error} = 1;
 260
 261         return;
 262     } elsif (not $self->flesh_browse_results($results)) {
 263         $logger->warn(
 264             "error in browse (flesh): " . $self->editor->event->{textcode}
 265         );
 266         $self->ctx->{browse_error} = 1;
 267
 268         return;
 269     }
 270
 271     return $results;
 272 }
 273
 274 # Find paging information, put it into $self->ctx, and return "real"
 275 # rows from $results, excluding those that contain only paging
 276 # information.
 277 sub infer_browse_paging {
 278     my ($self, $results) = @_;
 279
 280     foreach (@$results) {
 281         if ($_->{pivot_point}) {
 282             if ($_->{row_number} < 0) { # sic
 283                 $self->ctx->{forward_pivot} = $_->{pivot_point};
 284             } else {
 285                 $self->ctx->{back_pivot} = $_->{pivot_point};
 286             }
 287         }
 288     }
 289
 290     return [ grep { not defined $_->{pivot_point} } @$results ];
 291 }
 292
 293 sub leading_article_test {
 294     my ($self, $qtype, $bterm) = @_;
 295
 296     my $flag_name = "opac.browse.warnable_regexp_per_class";
 297     my $flag = $self->ctx->{get_cgf}->($flag_name);
 298
 299     return unless $flag->enabled eq 't';
 300
 301     my $map;
 302
 303     eval { $map = OpenSRF::Utils::JSON->JSON2perl($flag->value); };
 304     if ($@) {
 305         $logger->warn("cgf '$flag_name' enabled but value is invalid JSON? $@");
 306         return;
 307     }
 308
 309     # Don't crash over any of the things that could go wrong in here:
 310     eval {
 311         if ($map->{$qtype}) {
 312             if ($bterm =~ qr/$map->{$qtype}/i) {
 313                 $self->ctx->{browse_leading_article_warning} = 1;
 314                 ($self->ctx->{browse_leading_article_alternative} = $bterm) =~
 315                     s/$map->{$qtype}//;
 316             }
 317         }
 318     };
 319     if ($@) {
 320         $logger->warn("cgf '$flag_name' has valid JSON in value, but: $@");
 321     }
 322 }
 323
 324 sub load_browse {
 325     my ($self) = @_;
 326
 327     _init_browse_cache();
 328
 329     # If there's a user logged in, flesh extended user info so we can get
 330     # her opac.hits_per_page setting, if any.
 331     if ($self->ctx->{user}) {
 332         $self->prepare_extended_user_info('settings');
 333         if (my $setting = first { $_->name eq 'opac.hits_per_page' }
 334             @{$self->ctx->{user}->settings}) {
 335
 336             $self->ctx->{opac_hits_per_page} =
 337                 int(OpenSRF::Utils::JSON->JSON2perl($setting->value));
 338         }
 339     }
 340
 341     my $pager_shortcuts = $self->ctx->{get_org_setting}->(
 342         $self->ctx->{physical_loc} || $self->ctx->{search_ou} ||
 343             $self->ctx->{aou_tree}->id, 'opac.browse.pager_shortcuts'
 344     );
 345     if ($pager_shortcuts) {
 346         my @pager_shortcuts;
 347         while ($pager_shortcuts =~ s/(\*(.+?)\*)//) {
 348             push @pager_shortcuts, [substr($2, 0, 1), $2];
 349         }
 350         push @pager_shortcuts, map { [$_, $_] } split //, $pager_shortcuts;
 351         $self->ctx->{pager_shortcuts} = \@pager_shortcuts;
 352     }
 353
 354     if ($self->cgi->param('qtype') and defined $self->cgi->param('bterm')) {
 355
 356         $self->leading_article_test(
 357             $self->cgi->param('qtype'),
 358             $self->cgi->param('bterm')
 359         );
 360
 361         my ($cache_key, @params) = $self->prepare_browse_parameters;
 362
 363         my $results = $browse_cache->get_cache($cache_key);
 364         if (not $results) {
 365             $results = $self->load_browse_impl(@params);
 366             if ($results) {
 367                 $browse_cache->put_cache($cache_key, $results, $browse_timeout);
 368             }
 369         }
 370
 371         if ($results) {
 372             $self->ctx->{browse_results} = $self->infer_browse_paging($results);
 373         }
 374
 375         # We don't need an else clause to send the user a 5XX error or
 376         # anything. Errors will have been logged, and $ctx will be
 377         # prepared so a template can show a nicer error to the user.
 378     }
 379
 380     return Apache2::Const::OK;
 381 }
 382
 383 1;