1d49aa5dae0140a478672e2f8b625c5ddff93c72
[working/Evergreen.git] / 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     # By applying grep in this way, we get acsaf objects that *have* and
123     # therefore *aren't* main entries, which is what we want.
124     foreach my $acsaf (values(%$acsaf_table)) {
125         my @fields = $record->field($acsaf->tag);
126         my %sf_lookup = map { $_ => 1 } split("", $acsaf->display_sf_list);
127         my @headings;
128
129         foreach my $field (@fields) {
130             my $h = { main_entry => ( $acsaf->main_entry ? 0 : 1 ),
131                       heading => _get_authority_heading($field, \%sf_lookup), $acsaf->joiner };
132
133             # XXX I was getting "target" from authority.authority_linking, but
134             # that makes no sense: that table can only tell you that one
135             # authority record as a whole points at another record.  It does
136             # not record when a specific *field* in one authority record
137             # points to another record (not that it makes much sense for
138             # one authority record to have links to multiple others, but I can't
139             # say there definitely aren't cases for that).
140             $h->{target} = $2
141                 if ($field->subfield('0') || "") =~ /(^|\))(\d+)$/;
142
143             # The target is the row id if this is a main entry...
144             $h->{target} = $row->{id} if $h->{main_entry};
145
146             push @headings, $h;
147         }
148
149         push @{$row->{headings}}, {$acsaf->id => \@headings} if @headings;
150     }
151
152     return $row;
153 }
154
155 sub map_authority_headings_to_results {
156     my ($self, $linked, $results, $auth_ids, $authority_field_name) = @_;
157
158     # Use the linked authority records' control sets to find and pick
159     # out non-main-entry headings. Build the headings and make a
160     # combined data structure for the template's use.
161     my %linked_headings_by_auth_id = map {
162         $_->{id} => $self->find_authority_headings_and_notes($_)
163     } @$linked;
164
165     # Graft this authority heading data onto our main result set at the
166     # named column, either "authorities" or "sees".
167     foreach my $row (@$results) {
168         $row->{$authority_field_name} = [
169             map { $linked_headings_by_auth_id{$_} } @{$row->{$authority_field_name}}
170         ];
171     }
172
173     # Get linked-bib counts for each of those authorities, and put THAT
174     # information into place in the data structure.
175     my $counts = $self->editor->json_query({
176         select => {
177             abl => [
178                 {column => "id", transform => "count",
179                     alias => "count", aggregate => 1},
180                 "authority"
181             ]
182         },
183         from => {abl => {}},
184         where => {
185             "+abl" => {
186                 authority => [
187                     @$auth_ids,
188                     $U->unique_unnested_numbers(map { $_->{target} } @$linked)
189                 ]
190             }
191         }
192     }) or return;
193
194     my %auth_counts = map { $_->{authority} => $_->{count} } @$counts;
195
196     # Soooo nesty!  We look for places where we'll need a count of bibs
197     # linked to an authority record, and put it there for the template to find.
198     for my $row (@$results) {
199         for my $auth (@{$row->{$authority_field_name}}) {
200             if ($auth->{headings}) {
201                 for my $outer_heading (@{$auth->{headings}}) {
202                     for my $heading_blob (@{(values %$outer_heading)[0]}) {
203                         if ($heading_blob->{target}) {
204                             $heading_blob->{target_count} =
205                                 $auth_counts{$heading_blob->{target}};
206                         }
207                     }
208                 }
209             }
210         }
211     }
212 }
213
214 # flesh_browse_results() attaches data from authority records. It
215 # changes $results and returns 1 for success, undef for failure (in which
216 # case $self->editor->event should always point to the reason for failure).
217 # $results must be an arrayref of result rows from the DB's metabib.browse()
218 sub flesh_browse_results {
219     my ($self, $results) = @_;
220
221     for my $authority_field_name ( qw/authorities sees/ ) {
222         for my $r (@$results) {
223             # Turn comma-seprated strings of numbers in "authorities" and "sees"
224             # columns into arrays.
225             if ($r->{$authority_field_name}) {
226                 $r->{$authority_field_name} = [split /,/, $r->{$authority_field_name}];
227             } else {
228                 $r->{$authority_field_name} = [];
229             }
230             $r->{"list_$authority_field_name"} = [ @{$r->{$authority_field_name} } ];
231         }
232
233         # Group them in one arrray, not worrying about dupes because we're about
234         # to use them in an IN () comparison in a SQL query.
235         my @auth_ids = map { @{$_->{$authority_field_name}} } @$results;
236
237         if (@auth_ids) {
238             # Get all linked authority records themselves
239             my $linked = $self->editor->json_query({
240                 select => {
241                     are => [qw/id marc control_set/],
242                     aalink => [{column => "target", transform => "array_agg",
243                         aggregate => 1}]
244                 },
245                 from => {
246                     are => {
247                         aalink => {
248                             type => "left",
249                             fkey => "id", field => "source"
250                         }
251                     }
252                 },
253                 where => {"+are" => {id => \@auth_ids}}
254             }) or return;
255
256             $self->map_authority_headings_to_results($linked, $results, \@auth_ids, $authority_field_name);
257         }
258     }
259
260     return 1;
261 }
262
263 sub load_browse_impl {
264     my ($self, @params) = @_;
265
266     my $results = $self->editor->json_query({
267         from => [ "metabib.browse", @params ]
268     });
269
270     if (not $results) {  # DB error, not empty result set.
271         $logger->warn(
272             "error in browse (direct): " . $self->editor->event->{textcode}
273         );
274         $self->ctx->{browse_error} = 1;
275
276         return;
277     } elsif (not $self->flesh_browse_results($results)) {
278         $logger->warn(
279             "error in browse (flesh): " . $self->editor->event->{textcode}
280         );
281         $self->ctx->{browse_error} = 1;
282
283         return;
284     }
285
286     return $results;
287 }
288
289 # Find paging information, put it into $self->ctx, and return "real"
290 # rows from $results, excluding those that contain only paging
291 # information.
292 sub infer_browse_paging {
293     my ($self, $results) = @_;
294
295     foreach (@$results) {
296         if ($_->{pivot_point}) {
297             if ($_->{row_number} < 0) { # sic
298                 $self->ctx->{forward_pivot} = $_->{pivot_point};
299             } else {
300                 $self->ctx->{back_pivot} = $_->{pivot_point};
301             }
302         }
303     }
304
305     return [ grep { not defined $_->{pivot_point} } @$results ];
306 }
307
308 sub leading_article_test {
309     my ($self, $qtype, $bterm) = @_;
310
311     my $flag_name = "opac.browse.warnable_regexp_per_class";
312     my $flag = $self->ctx->{get_cgf}->($flag_name);
313
314     return unless $flag->enabled eq 't';
315
316     my $map;
317
318     eval { $map = OpenSRF::Utils::JSON->JSON2perl($flag->value); };
319     if ($@) {
320         $logger->warn("cgf '$flag_name' enabled but value is invalid JSON? $@");
321         return;
322     }
323
324     # Don't crash over any of the things that could go wrong in here:
325     eval {
326         if ($map->{$qtype}) {
327             if ($bterm =~ qr/$map->{$qtype}/i) {
328                 $self->ctx->{browse_leading_article_warning} = 1;
329                 ($self->ctx->{browse_leading_article_alternative} = $bterm) =~
330                     s/$map->{$qtype}//;
331             }
332         }
333     };
334     if ($@) {
335         $logger->warn("cgf '$flag_name' has valid JSON in value, but: $@");
336     }
337 }
338
339 sub load_browse {
340     my ($self) = @_;
341
342     _init_browse_cache();
343
344     # If there's a user logged in, flesh extended user info so we can get
345     # her opac.hits_per_page setting, if any.
346     if ($self->ctx->{user}) {
347         $self->prepare_extended_user_info('settings');
348         if (my $setting = first { $_->name eq 'opac.hits_per_page' }
349             @{$self->ctx->{user}->settings}) {
350
351             $self->ctx->{opac_hits_per_page} =
352                 int(OpenSRF::Utils::JSON->JSON2perl($setting->value));
353         }
354     }
355
356     my $pager_shortcuts = $self->ctx->{get_org_setting}->(
357         $self->ctx->{physical_loc} || $self->ctx->{search_ou} ||
358             $self->ctx->{aou_tree}->id, 'opac.browse.pager_shortcuts'
359     );
360     if ($pager_shortcuts) {
361         my @pager_shortcuts;
362         while ($pager_shortcuts =~ s/(\*(.+?)\*)//) {
363             push @pager_shortcuts, [substr($2, 0, 1), $2];
364         }
365         push @pager_shortcuts, map { [$_, $_] } split //, $pager_shortcuts;
366         $self->ctx->{pager_shortcuts} = \@pager_shortcuts;
367     }
368
369     if ($self->cgi->param('qtype') and defined $self->cgi->param('bterm')) {
370
371         $self->leading_article_test(
372             $self->cgi->param('qtype'),
373             $self->cgi->param('bterm')
374         );
375
376         my ($cache_key, @params) = $self->prepare_browse_parameters;
377
378         my $results = $browse_cache->get_cache($cache_key);
379         if (not $results) {
380             $results = $self->load_browse_impl(@params);
381             if ($results) {
382                 $browse_cache->put_cache($cache_key, $results, $browse_timeout);
383             }
384         }
385
386         if ($results) {
387             $self->ctx->{browse_results} = $self->infer_browse_paging($results);
388         }
389
390         # We don't need an else clause to send the user a 5XX error or
391         # anything. Errors will have been logged, and $ctx will be
392         # prepared so a template can show a nicer error to the user.
393     }
394
395     return Apache2::Const::OK;
396 }
397
398 1;