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 $maps = $editor->search_action_hold_copy_map({hold => $hold->id});
 369         for(@$maps) {
 370             $editor->delete_action_hold_copy_map($_)
 371                 or return $editor->die_event;
 372         }
 373
 374         my $at_ses = OpenSRF::AppSession->create('open-ils.trigger');
 375         $at_ses->request(
 376             'open-ils.trigger.event.autocreate',
 377             'hold_request.cancel.expire_no_target',
 378             $hold, $hold->pickup_lib);
 379     }
 380
 381    return undef;
 382 }
 383
 384
 385 # ---------------------------------------------------------------------------
 386 # returns true if the given title (id) has no un-deleted volumes or
 387 # copies attached.  If a context volume is defined, a record
 388 # is considered empty only if the context volume is the only
 389 # remaining volume on the record.
 390 # ---------------------------------------------------------------------------
 391 sub title_is_empty {
 392     my($class, $editor, $rid, $vol_id) = @_;
 393
 394     # check if $rid is an object, because may be passing the volume
 395     # with a fleshed record in one of our callers.
 396     $rid = $rid->id() if (ref($rid));
 397
 398     return 0 if $rid == OILS_PRECAT_RECORD;
 399
 400     my $cnlist = $editor->search_asset_call_number(
 401         { record => $rid, deleted => 'f' }, { idlist => 1 } );
 402
 403     return 1 unless @$cnlist; # no attached volumes
 404     return 0 if @$cnlist > 1; # multiple attached volumes
 405     return 0 unless $$cnlist[0] == $vol_id; # attached volume is not the context vol.
 406
 407     # see if the sole remaining context volume has any attached copies
 408     for my $cn (@$cnlist) {
 409         my $copylist = $editor->search_asset_copy(
 410             [
 411                 { call_number => $cn, deleted => 'f' },
 412                 { limit => 1 },
 413             ], { idlist => 1 });
 414         return 0 if @$copylist; # false if we find any copies
 415     }
 416
 417     return 1;
 418 }
 419 1;