LP#1386347 Remove more unneeded map deleters
[Evergreen.git] / Open-ILS / src / perlmods / lib / OpenILS / Application / Cat / BibCommon.pm
1 package OpenILS::Application::Cat::BibCommon;
2 use strict; use warnings;
3 use OpenILS::Utils::CStoreEditor q/:funcs/;
4 use OpenSRF::Utils::Logger qw($logger);
5 use OpenILS::Application::AppUtils;
6 use OpenILS::Utils::Fieldmapper;
7 use OpenILS::Const qw/:const/;
8 use OpenSRF::AppSession;
9 use OpenILS::Event;
10 my $U = 'OpenILS::Application::AppUtils';
11 my $MARC_NAMESPACE = 'http://www.loc.gov/MARC21/slim';
12
13
14 # ---------------------------------------------------------------------------
15 # Shared bib mangling code.  Do not publish methods from here.
16 # ---------------------------------------------------------------------------
17
18 my $__bib_sources;
19 sub bib_source_from_name {
20     my $name = shift;
21     $logger->debug("searching for bib source: $name");
22
23     fetch_bib_sources();
24
25     my ($s) = grep { lc($_->source) eq lc($name) } @$__bib_sources;
26
27     return $s->id if $s;
28     return undef;
29 }
30
31 sub fetch_bib_sources {
32     $__bib_sources = new_editor()->retrieve_all_config_bib_source()
33         unless $__bib_sources;
34     return $__bib_sources;
35 }
36
37
38 sub biblio_record_replace_marc  {
39     my($class, $e, $recid, $newxml, $source, $fixtcn, $override, $strip_grps) = @_;
40
41     $override = { all => 1 } if($override && !ref $override);
42     $override = { all => 0 } if(!ref $override);
43
44     my $rec = $e->retrieve_biblio_record_entry($recid)
45         or return $e->die_event;
46
47     # See if there is a different record in the database that has our TCN value
48     # If we're not updating the TCN, all we care about it the marcdoc
49     # XXX should .update even bother with the tcn_info if it's not going to replace it?
50     # there is the potential for returning a TCN_EXISTS event, even though no replacement happens
51
52     my( $tcn, $tsource, $marcdoc, $evt);
53
54     if($fixtcn or $override->{all} or $override->{events}) {
55
56         ($tcn, $tsource, $marcdoc, $evt) = 
57             _find_tcn_info($e, $newxml, $override, $recid);
58
59         return $evt if $evt;
60
61         $rec->tcn_value($tcn) if ($tcn);
62         $rec->tcn_source($tsource);
63
64     } else {
65
66         $marcdoc = __make_marc_doc($newxml);
67     }
68
69     my $marc = $U->strip_marc_fields($e, $marcdoc, $strip_grps);
70
71     $rec->source(bib_source_from_name($source)) if $source;
72     $rec->editor($e->requestor->id);
73     $rec->edit_date('now');
74     $rec->marc($marc);
75     $e->update_biblio_record_entry($rec) or return $e->die_event;
76
77     return $rec;
78 }
79
80 sub biblio_record_xml_import {
81     my($class, $e, $xml, $source, $auto_tcn, $override, $strip_grps) = @_;
82
83     $override = { all => 1 } if($override && !ref $override);
84     $override = { all => 0 } if(!ref $override);
85
86     my( $evt, $tcn, $tcn_source, $marcdoc );
87
88     my $use_id = $e->retrieve_config_global_flag('cat.bib.use_id_for_tcn');
89     $use_id = ($use_id and $U->is_true($use_id->enabled));
90
91     if( $auto_tcn or $use_id ) {
92         # auto_tcn forces a blank TCN value so the DB will have to generate one for us
93         $marcdoc = __make_marc_doc($xml);
94     } else {
95         ( $tcn, $tcn_source, $marcdoc, $evt ) = _find_tcn_info($e, $xml, $override);
96         return $evt if $evt;
97     }
98
99     # Silence warnings when _find_tcn_info() fails
100     $tcn ||= '';
101     $tcn_source ||= '';
102     $logger->info("user ".$e->requestor->id.
103         " creating new biblio entry with tcn=$tcn and tcn_source $tcn_source");
104
105     my $marc = $U->strip_marc_fields($e, $marcdoc, $strip_grps);
106
107     my $record = Fieldmapper::biblio::record_entry->new;
108
109     $record->source(bib_source_from_name($source)) if $source;
110     $record->tcn_source($tcn_source);
111     $record->tcn_value($tcn) if ($tcn);
112     $record->creator($e->requestor->id);
113     $record->editor($e->requestor->id);
114     $record->create_date('now');
115     $record->edit_date('now');
116     $record->marc($marc);
117
118     $record = $e->create_biblio_record_entry($record) or return $e->die_event;
119
120     if($use_id) {
121         my $existing = $e->search_biblio_record_entry(
122             {   
123                 tcn_value => $record->id,
124                 deleted => 'f'
125             }, { 
126                 idlist => 1 
127             }
128         );
129
130         if(@$existing) {
131             # leave the auto-generated tcn_value in place
132             $logger->warn("Collision using internal ID as tcn_value for record " . $record->id);
133         } else {
134             $record->tcn_value($record->id);
135             $e->update_biblio_record_entry($record) or return $e->die_event;
136         }
137     }
138
139     $logger->info("marc create/import created new record ".$record->id);
140     return $record;
141 }
142
143 sub __make_marc_doc {
144     my $xml = shift;
145     my $marcxml = XML::LibXML->new->parse_string($xml);
146     $marcxml->documentElement->setNamespace($MARC_NAMESPACE, "marc", 1 );
147     $marcxml->documentElement->setNamespace($MARC_NAMESPACE);
148     __remove_empty_marc_nodes($marcxml);
149     return $marcxml;
150 }
151
152 # remove empty control fields, subfields, and variable data fields, which
153 # can creep in via less-than-correct imported MARC records or issues
154 # with templates
155 sub __remove_empty_marc_nodes {
156     my $marcxml = shift;
157
158     __remove_if_childless($_) foreach $marcxml->documentElement->getElementsByTagNameNS($MARC_NAMESPACE, 'controlfield');
159     __remove_if_childless($_) foreach $marcxml->documentElement->getElementsByTagNameNS($MARC_NAMESPACE, 'subfield');
160     __remove_if_childless($_) foreach $marcxml->documentElement->getElementsByTagNameNS($MARC_NAMESPACE, 'datafield');
161 }
162
163 sub __remove_if_childless {
164     my $node = shift;
165     my @children = $node->childNodes();
166     my $has_nonblank_children = 0;
167     # can do this more concisely by requiring XML::LibXML >= 1.70 and using nonBlankChildNodes()
168     foreach my $node ($node->childNodes()) {
169         if ($node->nodeType != XML::LibXML::XML_TEXT_NODE || $node->nodeValue !~ /^\s*$/) {
170             $has_nonblank_children = 1;
171             last;
172         }
173     }
174     $node->parentNode->removeChild($node) unless $has_nonblank_children;
175 }
176
177 sub _find_tcn_info { 
178     my $editor      = shift;
179     my $xml         = shift;
180     my $override    = shift;
181     my $existing_rec    = shift || 0;
182
183     $override = { all => 1 } if($override && !ref $override);
184     $override = { all => 0 } if(!ref $override);
185
186     # parse the XML
187     my $marcxml = __make_marc_doc($xml);
188
189     my $xpath = '//marc:controlfield[@tag="001"]';
190     my $tcn = $marcxml->documentElement->findvalue($xpath);
191     $logger->info("biblio import located 001 (tcn) value of $tcn");
192
193     $xpath = '//marc:controlfield[@tag="003"]';
194     my $tcn_source = $marcxml->documentElement->findvalue($xpath) || "System Local";
195
196     if(my $rec = _tcn_exists($editor, $tcn, $tcn_source, $existing_rec) ) {
197
198         my $origtcn = $tcn;
199         $tcn = find_free_tcn( $marcxml, $editor, $existing_rec );
200
201         # if we're overriding, try to find a different TCN to use
202         if( $override->{all} || grep { $_ eq 'TCN_EXISTS' } @{$override->{events}} ) {
203
204          # XXX Create ALLOW_ALT_TCN permission check support 
205
206             $logger->info("tcn value $tcn already exists, attempting to override");
207
208             if(!$tcn) {
209                 return ( 
210                     undef, 
211                     undef, 
212                     undef,
213                     OpenILS::Event->new(
214                         'OPEN_TCN_NOT_FOUND', 
215                             payload => $marcxml->toString())
216                     );
217             }
218
219         } else {
220
221             $logger->warn("tcn value $origtcn already exists in import/create");
222
223             # otherwise, return event
224             return ( 
225                 undef, 
226                 undef, 
227                 undef,
228                 OpenILS::Event->new( 
229                     'TCN_EXISTS', payload => { 
230                         dup_record  => $rec, 
231                         tcn         => $origtcn,
232                         new_tcn     => $tcn
233                         }
234                     )
235                 );
236         }
237     }
238
239     return ($tcn, $tcn_source, $marcxml);
240 }
241
242 sub find_free_tcn {
243
244     my $marcxml = shift;
245     my $editor = shift;
246     my $existing_rec = shift;
247
248     my $xpath = '//marc:datafield[@tag="901"]/marc:subfield[@code="a"]';
249     my ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
250
251     if (!$tcn) {
252         $xpath = '//marc:datafield[@tag="039"]/marc:subfield[@code="a"]';
253         ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
254     }
255
256     $xpath = '//marc:datafield[@tag="901"]/marc:subfield[@code="b"]';
257     my ($tcn_source) = $marcxml->documentElement->findvalue($xpath);
258     if (!$tcn_source) {
259         $xpath = '//marc:datafield[@tag="039"]/marc:subfield[@code="b"]';
260         $tcn_source = $marcxml->documentElement->findvalue($xpath) || "System Local";
261     }
262
263     if(_tcn_exists($editor, $tcn, $tcn_source, $existing_rec)) {
264         $tcn = undef;
265     }
266
267
268     if(!$tcn) {
269         $xpath = '//marc:datafield[@tag="020"]/marc:subfield[@code="a"]';
270         ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
271         $tcn_source = "ISBN";
272         if(_tcn_exists($editor, $tcn, $tcn_source, $existing_rec)) {$tcn = undef;}
273     }
274
275     if(!$tcn) { 
276         $xpath = '//marc:datafield[@tag="022"]/marc:subfield[@code="a"]';
277         ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
278         $tcn_source = "ISSN";
279         if(_tcn_exists($editor, $tcn, $tcn_source, $existing_rec)) {$tcn = undef;}
280     }
281
282     if(!$tcn) {
283         $xpath = '//marc:datafield[@tag="010"]';
284         ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
285         $tcn_source = "LCCN";
286         if(_tcn_exists($editor, $tcn, $tcn_source, $existing_rec)) {$tcn = undef;}
287     }
288
289     if(!$tcn) {
290         $xpath = '//marc:datafield[@tag="035"]/marc:subfield[@code="a"]';
291         ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
292         $tcn_source = "System Legacy";
293         if(_tcn_exists($editor, $tcn, $tcn_source, $existing_rec)) {$tcn = undef;}
294
295         if($tcn) {
296             $marcxml->documentElement->removeChild(
297                 $marcxml->documentElement->findnodes( '//marc:datafield[@tag="035"]' )
298             );
299         }
300     }
301
302     return undef unless $tcn;
303     return $tcn;
304 }
305
306
307
308 sub _tcn_exists {
309     my $editor = shift;
310     my $tcn = shift;
311     my $source = shift;
312     my $existing_rec = shift || 0;
313
314     if(!$tcn) {return 0;}
315
316     $logger->debug("tcn_exists search for tcn $tcn and source $source and id $existing_rec");
317
318     # XXX why does the source matter?
319 #   my $req = $session->request(      
320 #       { tcn_value => $tcn, tcn_source => $source, deleted => 'f' } );
321
322     my $recs = $editor->search_biblio_record_entry(
323         {tcn_value => $tcn, deleted => 'f', id => {'!=' => $existing_rec}}, {idlist =>1});
324
325     if(@$recs) {
326         $logger->debug("_tcn_exists is true for tcn : $tcn ($source)");
327         return $recs->[0];
328     }
329
330     $logger->debug("_tcn_exists is false for tcn : $tcn ($source)");
331     return 0;
332 }
333
334
335 sub delete_rec {
336    my($class, $editor, $rec_id ) = @_;
337
338    my $rec = $editor->retrieve_biblio_record_entry($rec_id)
339       or return $editor->event;
340
341    return undef if $U->is_true($rec->deleted);
342    
343    $rec->deleted('t');
344    $rec->active('f');
345    $rec->editor( $editor->requestor->id );
346    $rec->edit_date('now');
347
348    # Set the leader/05 to indicate that the record has been deleted
349    my $marc = $rec->marc();
350    $marc =~ s{(<leader>.{5}).}{$1d};
351    $rec->marc($marc);
352
353    $editor->update_biblio_record_entry($rec) or return $editor->event;
354
355     my $holds = $editor->search_action_hold_request({
356         target => $rec->id,
357         hold_type => 'T',
358         cancel_time => undef,
359         fulfillment_time => undef
360     });
361
362     for my $hold (@$holds) {
363
364         $hold->cancel_time('now');
365         $hold->cancel_cause(1); # un-targeted expiration.
366         $editor->update_action_hold_request($hold) or return $editor->die_event;
367
368         my $at_ses = OpenSRF::AppSession->create('open-ils.trigger');
369         $at_ses->request(
370             'open-ils.trigger.event.autocreate',
371             'hold_request.cancel.expire_no_target', 
372             $hold, $hold->pickup_lib);
373     }
374
375    return undef;
376 }
377
378
379 # ---------------------------------------------------------------------------
380 # returns true if the given title (id) has no un-deleted volumes or 
381 # copies attached.  If a context volume is defined, a record
382 # is considered empty only if the context volume is the only
383 # remaining volume on the record.  
384 # ---------------------------------------------------------------------------
385 sub title_is_empty {
386     my($class, $editor, $rid, $vol_id) = @_;
387
388     # check if $rid is an object, because may be passing the volume
389     # with a fleshed record in one of our callers.
390     $rid = $rid->id() if (ref($rid));
391
392     return 0 if $rid == OILS_PRECAT_RECORD;
393
394     my $cnlist = $editor->search_asset_call_number(
395         { record => $rid, deleted => 'f' }, { idlist => 1 } );
396
397     return 1 unless @$cnlist; # no attached volumes
398     return 0 if @$cnlist > 1; # multiple attached volumes
399     return 0 unless $$cnlist[0] == $vol_id; # attached volume is not the context vol.
400
401     # see if the sole remaining context volume has any attached copies
402     for my $cn (@$cnlist) {
403         my $copylist = $editor->search_asset_copy(
404             [
405                 { call_number => $cn, deleted => 'f' }, 
406                 { limit => 1 },
407             ], { idlist => 1 });
408         return 0 if @$copylist; # false if we find any copies
409     }
410
411     return 1;
412 }
413 1;