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