LP1207396 Patron self-registration web form
[working/Evergreen.git] / Open-ILS / src / perlmods / lib / OpenILS / WWW / EGCatLoader / Util.pm
1 package OpenILS::WWW::EGCatLoader;
2 use strict; use warnings;
3 use Apache2::Const -compile => qw(OK DECLINED FORBIDDEN HTTP_INTERNAL_SERVER_ERROR REDIRECT HTTP_BAD_REQUEST);
4 use File::Spec;
5 use Time::HiRes qw/time sleep/;
6 use OpenSRF::Utils::Cache;
7 use OpenSRF::Utils::Logger qw/$logger/;
8 use OpenILS::Utils::CStoreEditor qw/:funcs/;
9 use OpenILS::Utils::Fieldmapper;
10 use OpenILS::Application::AppUtils;
11 use OpenSRF::MultiSession;
12
13 my $U = 'OpenILS::Application::AppUtils';
14
15 my $ro_object_subs; # cached subs
16 our %cache = ( # cached data
17     map => {en_us => {}},
18     list => {en_us => {}},
19     search => {en_us => {}},
20     org_settings => {en_us => {}},
21     search_filter_groups => {en_us => {}},
22     aou_tree => {en_us => undef},
23     aouct_tree => {},
24     eg_cache_hash => undef,
25     authority_fields => {en_us => {}}
26 );
27
28 sub init_ro_object_cache {
29     my $self = shift;
30     my $e = $self->editor;
31     my $ctx = $self->ctx;
32
33     # reset org unit setting cache on each page load to avoid the
34     # requirement of reloading apache with each org-setting change
35     $cache{org_settings} = {};
36
37     if($ro_object_subs) {
38         # subs have been built.  insert into the context then move along.
39         $ctx->{$_} = $ro_object_subs->{$_} for keys %$ro_object_subs;
40         return;
41     }
42
43     # make all "field_safe" classes accesible by default in the template context
44     my @classes = grep {
45         ($Fieldmapper::fieldmap->{$_}->{field_safe} || '') =~ /true/i
46     } keys %{ $Fieldmapper::fieldmap };
47
48     for my $class (@classes) {
49
50         my $hint = $Fieldmapper::fieldmap->{$class}->{hint};
51         next if $hint eq 'aou'; # handled separately
52
53         my $ident_field =  $Fieldmapper::fieldmap->{$class}->{identity};
54         (my $eclass = $class) =~ s/Fieldmapper:://o;
55         $eclass =~ s/::/_/g;
56
57         my $list_key = "${hint}_list";
58         my $get_key = "get_$hint";
59         my $search_key = "search_$hint";
60
61         # Retrieve the full set of objects with class $hint
62         $ro_object_subs->{$list_key} = sub {
63             my $method = "retrieve_all_$eclass";
64             $cache{list}{$ctx->{locale}}{$hint} = $e->$method() unless $cache{list}{$ctx->{locale}}{$hint};
65             return $cache{list}{$ctx->{locale}}{$hint};
66         };
67
68         # locate object of class $hint with Ident field $id
69         $cache{map}{$hint} = {};
70         $ro_object_subs->{$get_key} = sub {
71             my $id = shift;
72             return $cache{map}{$ctx->{locale}}{$hint}{$id} if $cache{map}{$ctx->{locale}}{$hint}{$id};
73             ($cache{map}{$ctx->{locale}}{$hint}{$id}) = grep { $_->$ident_field eq $id } @{$ro_object_subs->{$list_key}->()};
74             return $cache{map}{$ctx->{locale}}{$hint}{$id};
75         };
76
77         # search for objects of class $hint where field=value
78         $cache{search}{$hint} = {};
79         $ro_object_subs->{$search_key} = sub {
80             my ($field, $val, $filterfield, $filterval) = @_;
81             my $method = "search_$eclass";
82             my $cacheval = $val;
83             if (ref $val) {
84                 $val = [sort(@$val)] if ref $val eq 'ARRAY';
85                 $cacheval = OpenSRF::Utils::JSON->perl2JSON($val);
86                 #$self->apache->log->info("cacheval : $cacheval");
87             }
88             my $search_obj = {$field => $val};
89             if($filterfield) {
90                 $search_obj->{$filterfield} = $filterval;
91                 $cacheval .= ':' . $filterfield . ':' . $filterval;
92             }
93             #$cache{search}{$ctx->{locale}}{$hint}{$field} = {} unless $cache{search}{$ctx->{locale}}{$hint}{$field};
94             $cache{search}{$ctx->{locale}}{$hint}{$field}{$cacheval} = $e->$method($search_obj)
95                 unless $cache{search}{$ctx->{locale}}{$hint}{$field}{$cacheval};
96             return $cache{search}{$ctx->{locale}}{$hint}{$field}{$cacheval};
97         };
98     }
99
100     $ro_object_subs->{aou_tree} = sub {
101
102         # fetch the org unit tree
103         unless($cache{aou_tree}{$ctx->{locale}}) {
104             my $tree = $e->search_actor_org_unit([
105                 {   parent_ou => undef},
106                 {   flesh            => -1,
107                     flesh_fields    => {aou =>  ['children']},
108                     order_by        => {aou => 'name'}
109                 }
110             ])->[0];
111
112             # flesh the org unit type for each org unit
113             # and simultaneously set the id => aou map cache
114             sub flesh_aout {
115                 my $node = shift;
116                 my $ro_object_subs = shift;
117                 my $ctx = shift;
118                 $node->ou_type( $ro_object_subs->{get_aout}->($node->ou_type) );
119                 $cache{map}{$ctx->{locale}}{aou}{$node->id} = $node;
120                 flesh_aout($_, $ro_object_subs, $ctx) foreach @{$node->children};
121             };
122             flesh_aout($tree, $ro_object_subs, $ctx);
123
124             $cache{aou_tree}{$ctx->{locale}} = $tree;
125         }
126
127         return $cache{aou_tree}{$ctx->{locale}};
128     };
129
130     # Add a special handler for the tree-shaped org unit cache
131     $ro_object_subs->{get_aou} = sub {
132         my $org_id = shift;
133         return undef unless defined $org_id;
134         $ro_object_subs->{aou_tree}->(); # force the org tree to load
135         return $cache{map}{$ctx->{locale}}{aou}{$org_id};
136     };
137
138     # Returns a flat list of aou objects.  often easier to manage than a tree.
139     $ro_object_subs->{aou_list} = sub {
140         $ro_object_subs->{aou_tree}->(); # force the org tree to load
141         return [ values %{$cache{map}{$ctx->{locale}}{aou}} ];
142     };
143
144     # returns the org unit object by shortname
145     $ro_object_subs->{get_aou_by_shortname} = sub {
146         my $sn = shift or return undef;
147         my $list = $ro_object_subs->{aou_list}->();
148         return (grep {$_->shortname eq $sn} @$list)[0];
149     };
150
151     $ro_object_subs->{aouct_tree} = sub {
152
153         # fetch the org unit tree
154         unless(exists $cache{aouct_tree}{$ctx->{locale}}) {
155             $cache{aouct_tree}{$ctx->{locale}} = undef;
156
157             my $tree_id = $e->search_actor_org_unit_custom_tree(
158                 {purpose => 'opac', active => 't'},
159                 {idlist => 1}
160             )->[0];
161
162             if ($tree_id) {
163                 my $node_tree = $e->search_actor_org_unit_custom_tree_node([
164                 {parent_node => undef, tree => $tree_id},
165                 {   flesh        => -1,
166                     flesh_fields => {aouctn => ['children', 'org_unit']},
167                     order_by     => {aouctn => 'sibling_order'}
168                 }
169                 ])->[0];
170
171                 # tree-ify the org units.  note that since the orgs are fleshed
172                 # upon retrieval, this org tree will not clobber ctx->{aou_tree}.
173                 my @nodes = ($node_tree);
174                 while (my $node = shift(@nodes)) {
175                     my $aou = $node->org_unit;
176                     $aou->children([]);
177                     for my $cnode (@{$node->children}) {
178                         my $child_org = $cnode->org_unit;
179                         $child_org->parent_ou($aou->id);
180                         $child_org->ou_type( $ro_object_subs->{get_aout}->($child_org->ou_type) );
181                         push(@{$aou->children}, $child_org);
182                         push(@nodes, $cnode);
183                     }
184                 }
185
186                 $cache{aouct_tree}{$ctx->{locale}} = $node_tree->org_unit;
187             }
188         }
189
190         return $cache{aouct_tree}{$ctx->{locale}};
191     };
192
193     # turns an ISO date into something TT can understand
194     $ro_object_subs->{parse_datetime} = sub {
195         my $date = shift;
196
197         # Probably an accidental entry like '0212' instead of '2012',
198         # but 1) the leading 0 may get stripped in cstore and
199         # 2) DateTime::Format::ISO8601 returns an error as years
200         # must be 2 or 4 digits
201         if ($date =~ m/^\d{3}-/) {
202             $logger->warn("Invalid date had a 3-digit year: $date");
203             $date = '0' . $date;
204         } elsif ($date =~ m/^\d{1}-/) {
205             $logger->warn("Invalid date had a 1-digit year: $date");
206             $date = '000' . $date;
207         }
208
209         my $cleansed_date = cleanse_ISO8601($date);
210
211         $date = DateTime::Format::ISO8601->new->parse_datetime($cleansed_date);
212         return sprintf(
213             "%0.2d:%0.2d:%0.2d %0.2d-%0.2d-%0.4d",
214             $date->hour,
215             $date->minute,
216             $date->second,
217             $date->day,
218             $date->month,
219             $date->year
220         );
221     };
222
223     # retrieve and cache org unit setting values
224     $ro_object_subs->{get_org_setting} = sub {
225         my($org_id, $setting) = @_;
226
227         $cache{org_settings}{$ctx->{locale}}{$org_id}{$setting} =
228             $U->ou_ancestor_setting_value($org_id, $setting)
229                 unless exists $cache{org_settings}{$ctx->{locale}}{$org_id}{$setting};
230
231         return $cache{org_settings}{$ctx->{locale}}{$org_id}{$setting};
232     };
233
234     # retrieve and cache acsaf values
235     $ro_object_subs->{get_authority_fields} = sub {
236         my ($control_set) = @_;
237
238         if (not exists $cache{authority_fields}{$ctx->{locale}}{$control_set}) {
239             my $acs = $e->search_authority_control_set_authority_field(
240                 {control_set => $control_set}
241             ) or return;
242             $cache{authority_fields}{$ctx->{locale}}{$control_set} =
243                 +{ map { $_->id => $_ } @$acs };
244         }
245
246         return $cache{authority_fields}{$ctx->{locale}}{$control_set};
247     };
248
249     $ctx->{$_} = $ro_object_subs->{$_} for keys %$ro_object_subs;
250 }
251
252 sub generic_redirect {
253     my $self = shift;
254     my $url = shift;
255     my $cookie = shift; # can be an array of cgi.cookie's
256
257     $self->apache->print(
258         $self->cgi->redirect(
259             -url => $url || 
260                 $self->cgi->param('redirect_to') || 
261                 $self->ctx->{referer} || 
262                 $self->ctx->{home_page},
263             -cookie => $cookie
264         )
265     );
266
267     return Apache2::Const::REDIRECT;
268 }
269
270 my $unapi_cache;
271 sub get_records_and_facets {
272     my ($self, $rec_ids, $facet_key, $unapi_args) = @_;
273
274     $unapi_args ||= {};
275     $unapi_args->{site} ||= $self->ctx->{aou_tree}->()->shortname;
276     $unapi_args->{depth} ||= $self->ctx->{aou_tree}->()->ou_type->depth;
277     $unapi_args->{flesh_depth} ||= 5;
278
279     $unapi_cache ||= OpenSRF::Utils::Cache->new('global');
280     my $unapi_cache_key_suffix = join(
281         '_',
282         $unapi_args->{site},
283         $unapi_args->{depth},
284         $unapi_args->{flesh_depth},
285         ($unapi_args->{pref_lib} || '')
286     );
287
288     my %tmp_data;
289     my $outer_self = $self;
290     $self->timelog("get_records_and_facets(): about to call multisession");
291     my $ses = OpenSRF::MultiSession->new(
292         app => 'open-ils.cstore',
293         cap => 10, # XXX config
294         success_handler => sub {
295             my($self, $req) = @_;
296             my $data = $req->{response}->[0]->content;
297
298             $outer_self->timelog("get_records_and_facets(): got response content");
299
300             # Protect against requests for non-existent records
301             return unless $data->{'unapi.bre'};
302
303             my $xml = XML::LibXML->new->parse_string($data->{'unapi.bre'})->documentElement;
304
305             $outer_self->timelog("get_records_and_facets(): parsed xml");
306             # Protect against legacy invalid MARCXML that might not have a 901c
307             my $bre_id;
308             my $bre_id_nodes =  $xml->find('*[@tag="901"]/*[@code="c"]');
309             if ($bre_id_nodes) {
310                 $bre_id =  $bre_id_nodes->[0]->textContent;
311             } else {
312                 $logger->warn("Missing 901 subfield 'c' in " . $xml->toString());
313             }
314             $tmp_data{$bre_id} = {id => $bre_id, marc_xml => $xml};
315
316             if ($bre_id) {
317                 # Let other backends grab our data now that we're done.
318                 my $key = 'TPAC_unapi_cache_'.$bre_id.'_'.$unapi_cache_key_suffix;
319                 my $cache_data = $unapi_cache->get_cache($key);
320                 if ($$cache_data{running}) {
321                     $unapi_cache->put_cache($key, { id => $bre_id, marc_xml => $data->{'unapi.bre'} }, 10);
322                 }
323             }
324
325
326             $outer_self->timelog("get_records_and_facets(): end of success handler");
327         }
328     );
329
330     $self->timelog("get_records_and_facets(): about to call unapi.bre via json_query (rec_ids has " . scalar(@$rec_ids));
331
332     my @loop_recs = @$rec_ids;
333     my %rec_timeout;
334
335     while (my $bid = shift @loop_recs) {
336
337         sleep(0.1) if $rec_timeout{$bid};
338
339         my $unapi_cache_key = 'TPAC_unapi_cache_'.$bid.'_'.$unapi_cache_key_suffix;
340         my $unapi_data = $unapi_cache->get_cache($unapi_cache_key) || {};
341
342         if ($unapi_data->{running}) { #cache entry from ongoing, concurrent retrieval
343             if (!$rec_timeout{$bid}) {
344                 $rec_timeout{$bid} = time() + 10;
345             }
346
347             if ( time() > $rec_timeout{$bid} ) { # we've waited too long. just do it
348                 $unapi_data = {};
349                 delete $rec_timeout{$bid};
350             } else { # we'll pause next time around to let this one try again
351                 push(@loop_recs, $bid);
352                 next;
353             }
354         }
355
356         if ($unapi_data->{marc_xml}) { # we got data from the cache
357             $unapi_data->{marc_xml} = XML::LibXML->new->parse_string($unapi_data->{marc_xml})->documentElement;
358             $tmp_data{$unapi_data->{id}} = $unapi_data;
359         } else { # we're the first or we timed out. success_handler will populate the real value
360             $unapi_cache->put_cache($unapi_cache_key, { running => $$ }, 10);
361             $ses->request(
362                 'open-ils.cstore.json_query',
363                  {from => [
364                     'unapi.bre', $bid, 'marcxml','record', 
365                     $unapi_args->{flesh}, 
366                     $unapi_args->{site}, 
367                     $unapi_args->{depth}, 
368                     'acn=>' . $unapi_args->{flesh_depth} . ',acp=>' . $unapi_args->{flesh_depth}, 
369                     undef, undef, $unapi_args->{pref_lib}
370                 ]}
371             );
372         }
373
374     }
375
376
377     $self->timelog("get_records_and_facets():almost ready to fetch facets");
378     # collect the facet data
379     my $search = OpenSRF::AppSession->create('open-ils.search');
380     my $facet_req = $search->request(
381         'open-ils.search.facet_cache.retrieve', $facet_key
382     ) if $facet_key;
383
384     # gather up the unapi recs
385     $ses->session_wait(1);
386     $self->timelog("get_records_and_facets():past session wait");
387
388     my $facets = {};
389     if ($facet_key) {
390         my $tmp_facets = $facet_req->gather(1);
391         $self->timelog("get_records_and_facets(): gathered facet data");
392         for my $cmf_id (keys %$tmp_facets) {
393
394             # sort highest to lowest match count
395             my @entries;
396             my $entries = $tmp_facets->{$cmf_id};
397             for my $ent (keys %$entries) {
398                 push(@entries, {value => $ent, count => $$entries{$ent}});
399             };
400
401             # Sort facet entries by 1) count descending, 2) text ascending
402             @entries = sort {
403                 $b->{count} <=> $a->{count} ||
404                 $a->{value} cmp $b->{value}
405             } @entries;
406
407             $facets->{$cmf_id} = {
408                 cmf => $self->ctx->{get_cmf}->($cmf_id),
409                 data => \@entries
410             }
411         }
412         $self->timelog("get_records_and_facets(): gathered/sorted facet data");
413     } else {
414         $facets = undef;
415     }
416
417     $search->kill_me;
418
419     return ($facets, map { $tmp_data{$_} } @$rec_ids);
420 }
421
422 sub _resolve_org_id_or_shortname {
423     my ($self, $str) = @_;
424
425     if (length $str) {
426         # Match on shortname case insensitively, but only if there's exactly
427         # one match.  We wouldn't want the system to arbitrarily interpret
428         # 'foo' as either the org unit with shortname 'FOO' or 'Foo' and fail
429         # to make it clear to the user which one was chosen and why.
430         my $res = $self->editor->search_actor_org_unit({
431             shortname => {
432                 '=' => {
433                     transform => 'evergreen.lowercase',
434                     value => lc($str)
435                 }
436             }
437         });
438         return $res->[0]->id if $res and @$res == 1;
439     }
440
441     # Note that we don't validate IDs; we only try a shortname lookup and then
442     # assume anything else must be an ID.
443     return int($str); # Wrapping in int() prevents 500 on unmatched string.
444 }
445
446 sub _get_search_lib {
447     my $self = shift;
448     my $ctx = $self->ctx;
449
450     # avoid duplicate lookups
451     return $ctx->{search_ou} if $ctx->{search_ou};
452
453     my $loc = $ctx->{copy_location_group_org};
454     return $loc if $loc;
455
456     # loc param takes precedence
457     # XXX ^-- over what exactly? We could use clarification here. To me it looks
458     # like locg takes precedence over loc which in turn takes precedence over
459     # request headers which take precedence over pref_lib (which can be
460     # specified a lot of different ways and eventually falls back to
461     # physical_loc) and it all finally defaults to top of the org tree.
462     # To say nothing of all the code that doesn't look to this function at all
463     # but rather accesses some subset of these inputs directly.
464
465     $loc = $self->cgi->param('loc');
466     return $loc if $loc;
467
468     if ($self->apache->headers_in->get('OILS-Search-Lib')) {
469         return $self->apache->headers_in->get('OILS-Search-Lib');
470     }
471
472     my $pref_lib = $self->_get_pref_lib();
473     return $pref_lib if $pref_lib;
474
475     return $ctx->{aou_tree}->()->id;
476 }
477
478 sub _get_pref_lib {
479     my $self = shift;
480     my $ctx = $self->ctx;
481
482     # plib param takes precedence
483     my $plib = $self->cgi->param('plib');
484     return $plib if $plib;
485
486     if ($self->apache->headers_in->get('OILS-Pref-Lib')) {
487         return $self->apache->headers_in->get('OILS-Pref-Lib');
488     }
489
490     if ($ctx->{user}) {
491         # See if the user has a search library preference
492         my $lset = $self->editor->search_actor_user_setting({
493             usr => $ctx->{user}->id, 
494             name => 'opac.default_search_location'
495         })->[0];
496         return OpenSRF::Utils::JSON->JSON2perl($lset->value) if $lset;
497
498         # Otherwise return the user's home library
499         my $ou = $ctx->{user}->home_ou;
500         return ref($ou) ? $ou->id : $ou;
501     }
502
503     if ($ctx->{physical_loc}) {
504         return $ctx->{physical_loc};
505     }
506
507 }
508
509 # This is defensively coded since we don't do much manual reading from the
510 # file system in this module.
511 sub load_eg_cache_hash {
512     my ($self) = @_;
513
514     # just a context helper
515     $self->ctx->{eg_cache_hash} = sub { return $cache{eg_cache_hash}; };
516
517     # Need to actually load the value? If already done, move on.
518     return if defined $cache{eg_cache_hash};
519
520     # In this way even if we fail, we won't slow things down by ever trying
521     # again within this Apache process' lifetime.
522     $cache{eg_cache_hash} = 0;
523
524     my $path = File::Spec->catfile(
525         $self->apache->document_root, "eg_cache_hash"
526     );
527
528     if (not open FH, "<$path") {
529         $self->apache->log->warn("error opening $path : $!");
530         return;
531     } else {
532         my $buf;
533         my $rv = read FH, $buf, 64;  # defensive
534         close FH;
535
536         if (not defined $rv) {  # error
537             $self->apache->log->warn("error reading $path : $!");
538         } elsif ($rv > 0) {     # no error, something read
539             chomp $buf;
540             $cache{eg_cache_hash} = $buf;
541         }
542     }
543 }
544
545 # Extracts the copy location org unit and group from the 
546 # "logc" param, which takes the form org_id:grp_id.
547 sub extract_copy_location_group_info {
548     my $self = shift;
549     my $ctx = $self->ctx;
550     if (my $clump = $self->cgi->param('locg')) {
551         my ($org, $grp) = split(/:/, $clump);
552         $ctx->{copy_location_group_org} =
553             $self->_resolve_org_id_or_shortname($org);
554         $ctx->{copy_location_group} = $grp if $grp;
555     }
556 }
557
558 sub load_copy_location_groups {
559     my $self = shift;
560     my $ctx = $self->ctx;
561
562     # User can access to the search location groups at the current 
563     # search lib, the physical location lib, and the patron's home ou.
564     my @ctx_orgs = $ctx->{search_ou};
565     push(@ctx_orgs, $ctx->{physical_loc}) if $ctx->{physical_loc};
566     push(@ctx_orgs, $ctx->{user}->home_ou) if $ctx->{user};
567
568     my $grps = $self->editor->search_asset_copy_location_group([
569         {
570             opac_visible => 't',
571             owner => {
572                 in => {
573                     select => {aou => [{
574                         column => 'id', 
575                         transform => 'actor.org_unit_full_path',
576                         result_field => 'id',
577                     }]},
578                     from => 'aou',
579                     where => {id => \@ctx_orgs}
580                 }
581             }
582         },
583         {order_by => {acplg => 'pos'}}
584     ]);
585
586     my %buckets;
587     push(@{$buckets{$_->owner}}, $_) for @$grps;
588     $ctx->{copy_location_groups} = \%buckets;
589 }
590
591 sub set_file_download_headers {
592     my $self = shift;
593     my $filename = shift;
594     my $ctype = shift || "text/plain; encoding=utf8";
595
596     $self->apache->content_type($ctype);
597
598     $self->apache->headers_out->add(
599         "Content-Disposition",
600         "attachment;filename=$filename"
601     );
602
603     return Apache2::Const::OK;
604 }
605
606 sub apache_log_if_event {
607     my ($self, $event, $prefix_text, $success_ok, $level) = @_;
608
609     $prefix_text ||= "Evergreen returned event";
610     $success_ok ||= 0;
611     $level ||= "warn";
612
613     chomp $prefix_text;
614     $prefix_text .= ": ";
615
616     my $code = $U->event_code($event);
617     if (defined $code and ($code or not $success_ok)) {
618         $self->apache->log->$level(
619             $prefix_text .
620             ($event->{textcode} || "") . " ($code)" .
621             ($event->{note} ? (": " . $event->{note}) : "")
622         );
623         return 1;
624     }
625
626     return;
627 }
628
629 sub load_search_filter_groups {
630     my $self = shift;
631     my $ctx_org = shift;
632     my $org_list = $U->get_org_ancestors($ctx_org, 1);
633
634     my %seen;
635     for my $org_id (@$org_list) {
636
637         my $grps;
638         if (! ($grps = $cache{search_filter_groups}{$org_id}) ) {
639             $grps = $self->editor->search_actor_search_filter_group([
640                 {owner => $org_id},
641                 {   flesh => 2, 
642                     flesh_fields => {
643                         asfg => ['entries'],
644                         asfge => ['query']
645                     },
646                     order_by => {asfge => 'pos'}
647                 }
648             ]);
649             $cache{search_filter_groups}{$org_id} = $grps;
650         }
651
652         # for the current context, if a descendant org has a group 
653         # with a matching code replace the group from the parent.
654         $seen{$_->code} = $_ for @$grps;
655     }
656
657     return $self->ctx->{search_filter_groups} = \%seen;
658 }
659
660
661 sub check_for_temp_list_warning {
662     my $self = shift;
663     my $ctx = $self->ctx;
664     my $cgi = $self->cgi;
665
666     my $lib = $self->_get_search_lib;
667     my $warn = ($ctx->{get_org_setting}->($lib || 1, 'opac.patron.temporary_list_warn')) ? 1 : 0;
668
669     if ($warn && $ctx->{user}) {
670         $self->_load_user_with_prefs;
671         my $map = $ctx->{user_setting_map};
672         $warn = 0 if ($$map{'opac.temporary_list_no_warn'});
673     }
674
675     # Check for a cookie disabling the warning.
676     $warn = 0 if ($warn && $cgi->cookie('no_temp_list_warn'));
677
678     return $warn;
679 }
680
681 sub load_org_util_funcs {
682     my $self = shift;
683     my $ctx = $self->ctx;
684
685     # evaluates to true if test_ou is within the same depth-
686     # scoped tree as ctx_ou. both ou's are org unit objects.
687     $ctx->{org_within_scope} = sub {
688         my ($ctx_ou, $test_ou, $depth) = @_;
689
690         return 1 if $ctx_ou->id == $test_ou->id;
691
692         if ($depth) {
693
694             # find the top-most ctx-org ancestor at the provided depth
695             while ($depth < $ctx_ou->ou_type->depth 
696                     and $ctx_ou->id != $test_ou->id) {
697                 $ctx_ou = $ctx->{get_aou}->($ctx_ou->parent_ou);
698             }
699
700             # the preceeding loop may have landed on our org
701             return 1 if $ctx_ou->id == $test_ou->id;
702
703         } else {
704
705             return 1 if defined $depth; # $depth == 0;
706         }
707
708         for my $child (@{$ctx_ou->children}) {
709             return 1 if $ctx->{org_within_scope}->($child, $test_ou);
710         }
711
712         return 0;
713     };
714
715     # Returns true if the provided org unit is within the same 
716     # org unit hiding depth-scoped tree as the physical location.
717     # Org unit hiding is based on the immutable physical_loc
718     # and is not meant to change as search/pref/etc libs change
719     $ctx->{org_within_hiding_scope} = sub {
720         my $org_id = shift;
721         my $ploc = $ctx->{physical_loc} or return 1;
722
723         my $depth = $ctx->{get_org_setting}->(
724             $ploc, 'opac.org_unit_hiding.depth');
725
726         return 1 unless $depth; # 0 or undef
727
728         return $ctx->{org_within_scope}->( 
729             $ctx->{get_aou}->($ploc), 
730             $ctx->{get_aou}->($org_id), $depth);
731  
732     };
733
734     # Evaluates to true if the context org (defaults to get_library) 
735     # is not within the hiding scope.  Also evaluates to true if the 
736     # user's pref_ou is set and it's out of hiding scope.
737     # Always evaluates to true when ctx.is_staff
738     $ctx->{org_hiding_disabled} = sub {
739         my $ctx_org = shift || $ctx->{search_ou};
740
741         return 1 if $ctx->{is_staff};
742
743         # beware locg values formatted as org:loc
744         $ctx_org =~ s/:.*//g;
745
746         return 1 if !$ctx->{org_within_hiding_scope}->($ctx_org);
747
748         return 1 if $ctx->{pref_ou} and $ctx->{pref_ou} != $ctx_org 
749             and !$ctx->{org_within_hiding_scope}->($ctx->{pref_ou});
750
751         return 0;
752     };
753
754 }
755
756 # returns the list of org unit IDs for which the 
757 # selected org unit setting returned a true value
758 sub setting_is_true_for_orgs {
759     my ($self, $setting) = @_;
760     my $ctx = $self->ctx;
761     my @valid_orgs;
762
763     my $test_org;
764     $test_org = sub {
765         my $org = shift;
766         push (@valid_orgs, $org->id) if
767             $ctx->{get_org_setting}->($org->id, $setting);
768         $test_org->($_) for @{$org->children};
769     };
770
771     $test_org->($ctx->{aou_tree}->());
772     return \@valid_orgs;
773 }
774     
775
776
777 1;