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) = @_;
  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 $import_loc = $$override{import_location};
  70     my $ancestors = $U->get_org_ancestors($import_loc) if ($import_loc);
  71     my $trash_tags = $e->search_vandelay_import_bib_trash_fields({owner => $ancestors}) if ($ancestors);
  72
  73     if ($trash_tags && @$trash_tags) {
  74         for my $tag (@$trash_tags) {
  75             for my $node ($marcdoc->findnodes('//*[@tag="'.$tag->field.'"]')) {
  76                 $node->parentNode->removeChild($node);
  77             }
  78         }
  79     }
  80
  81
  82         $rec->source(bib_source_from_name($source)) if $source;
  83         $rec->editor($e->requestor->id);
  84         $rec->edit_date('now');
  85         $rec->marc( $U->entityize( $marcdoc->documentElement->toString ) );
  86         $e->update_biblio_record_entry($rec) or return $e->die_event;
  87
  88         return $rec;
  89 }
  90
  91 sub biblio_record_xml_import {
  92         my($class, $e, $xml, $source, $auto_tcn, $override) = @_;
  93
  94     $override = { all => 1 } if($override && !ref $override);
  95     $override = { all => 0 } if(!ref $override);
  96
  97         my( $evt, $tcn, $tcn_source, $marcdoc );
  98
  99     my $use_id = $e->retrieve_config_global_flag('cat.bib.use_id_for_tcn');
 100     $use_id = ($use_id and $U->is_true($use_id->enabled));
 101
 102         if( $auto_tcn or $use_id ) {
 103                 # auto_tcn forces a blank TCN value so the DB will have to generate one for us
 104                 $marcdoc = __make_marc_doc($xml);
 105         } else {
 106                 ( $tcn, $tcn_source, $marcdoc, $evt ) = _find_tcn_info($e, $xml, $override);
 107                 return $evt if $evt;
 108         }
 109
 110     my $import_loc = $$override{import_location};
 111     my $ancestors = $U->get_org_ancestors($import_loc) if ($import_loc);
 112     my $trash_tags = $e->search_vandelay_import_bib_trash_fields({owner => $ancestors}) if ($ancestors);
 113
 114     if ($trash_tags && @$trash_tags) {
 115         for my $tag (@$trash_tags) {
 116             for my $node ($marcdoc->findnodes('//*[@tag="'.$tag.'"]')) {
 117                 $node->parentNode->removeChild($node);
 118             }
 119         }
 120     }
 121
 122         # Silence warnings when _find_tcn_info() fails
 123         $tcn ||= '';
 124         $tcn_source ||= '';
 125         $logger->info("user ".$e->requestor->id.
 126                 " creating new biblio entry with tcn=$tcn and tcn_source $tcn_source");
 127
 128         my $record = Fieldmapper::biblio::record_entry->new;
 129
 130         $record->source(bib_source_from_name($source)) if $source;
 131         $record->tcn_source($tcn_source);
 132         $record->tcn_value($tcn) if ($tcn);
 133         $record->creator($e->requestor->id);
 134         $record->editor($e->requestor->id);
 135         $record->create_date('now');
 136         $record->edit_date('now');
 137         $record->marc($U->entityize($marcdoc->documentElement->toString));
 138
 139     $record = $e->create_biblio_record_entry($record) or return $e->die_event;
 140
 141     if($use_id) {
 142         my $existing = $e->search_biblio_record_entry(
 143             {
 144                 tcn_value => $record->id,
 145                 deleted => 'f'
 146             }, {
 147                 idlist => 1
 148             }
 149         );
 150
 151         if(@$existing) {
 152             # leave the auto-generated tcn_value in place
 153             $logger->warn("Collision using internal ID as tcn_value for record " . $record->id);
 154         } else {
 155             $record->tcn_value($record->id);
 156             $e->update_biblio_record_entry($record) or return $e->die_event;
 157         }
 158     }
 159
 160         $logger->info("marc create/import created new record ".$record->id);
 161         return $record;
 162 }
 163
 164 sub __make_marc_doc {
 165         my $xml = shift;
 166         my $marcxml = XML::LibXML->new->parse_string($xml);
 167         $marcxml->documentElement->setNamespace($MARC_NAMESPACE, "marc", 1 );
 168         $marcxml->documentElement->setNamespace($MARC_NAMESPACE);
 169         __remove_empty_marc_nodes($marcxml);
 170         return $marcxml;
 171 }
 172
 173 # remove empty control fields, subfields, and variable data fields, which
 174 # can creep in via less-than-correct imported MARC records or issues
 175 # with templates
 176 sub __remove_empty_marc_nodes {
 177         my $marcxml = shift;
 178
 179         __remove_if_childless($_) foreach $marcxml->documentElement->getElementsByTagNameNS($MARC_NAMESPACE, 'controlfield');
 180         __remove_if_childless($_) foreach $marcxml->documentElement->getElementsByTagNameNS($MARC_NAMESPACE, 'subfield');
 181         __remove_if_childless($_) foreach $marcxml->documentElement->getElementsByTagNameNS($MARC_NAMESPACE, 'datafield');
 182 }
 183
 184 sub __remove_if_childless {
 185         my $node = shift;
 186         my @children = $node->childNodes();
 187         my $has_nonblank_children = 0;
 188         # can do this more concisely by requiring XML::LibXML >= 1.70 and using nonBlankChildNodes()
 189         foreach my $node ($node->childNodes()) {
 190                 if ($node->nodeType != XML::LibXML::XML_TEXT_NODE || $node->nodeValue !~ /^\s*$/) {
 191                         $has_nonblank_children = 1;
 192                         last;
 193                 }
 194         }
 195         $node->parentNode->removeChild($node) unless $has_nonblank_children;
 196 }
 197
 198 sub _find_tcn_info {
 199         my $editor              = shift;
 200         my $xml                 = shift;
 201         my $override    = shift;
 202         my $existing_rec        = shift || 0;
 203
 204     $override = { all => 1 } if($override && !ref $override);
 205     $override = { all => 0 } if(!ref $override);
 206
 207         # parse the XML
 208         my $marcxml = __make_marc_doc($xml);
 209
 210         my $xpath = '//marc:controlfield[@tag="001"]';
 211         my $tcn = $marcxml->documentElement->findvalue($xpath);
 212         $logger->info("biblio import located 001 (tcn) value of $tcn");
 213
 214         $xpath = '//marc:controlfield[@tag="003"]';
 215         my $tcn_source = $marcxml->documentElement->findvalue($xpath) || "System Local";
 216
 217         if(my $rec = _tcn_exists($editor, $tcn, $tcn_source, $existing_rec) ) {
 218
 219                 my $origtcn = $tcn;
 220                 $tcn = find_free_tcn( $marcxml, $editor, $existing_rec );
 221
 222                 # if we're overriding, try to find a different TCN to use
 223                 if( $override->{all} || grep { $_ eq 'TCN_EXISTS' } @{$override->{events}} ) {
 224
 225          # XXX Create ALLOW_ALT_TCN permission check support
 226
 227                         $logger->info("tcn value $tcn already exists, attempting to override");
 228
 229                         if(!$tcn) {
 230                                 return (
 231                                         undef,
 232                                         undef,
 233                                         undef,
 234                                         OpenILS::Event->new(
 235                                                 'OPEN_TCN_NOT_FOUND',
 236                                                         payload => $marcxml->toString())
 237                                         );
 238                         }
 239
 240                 } else {
 241
 242                         $logger->warn("tcn value $origtcn already exists in import/create");
 243
 244                         # otherwise, return event
 245                         return (
 246                                 undef,
 247                                 undef,
 248                                 undef,
 249                                 OpenILS::Event->new(
 250                                         'TCN_EXISTS', payload => {
 251                                                 dup_record      => $rec,
 252                                                 tcn                     => $origtcn,
 253                                                 new_tcn         => $tcn
 254                                                 }
 255                                         )
 256                                 );
 257                 }
 258         }
 259
 260         return ($tcn, $tcn_source, $marcxml);
 261 }
 262
 263 sub find_free_tcn {
 264
 265         my $marcxml = shift;
 266         my $editor = shift;
 267         my $existing_rec = shift;
 268
 269         my $xpath = '//marc:datafield[@tag="901"]/marc:subfield[@code="a"]';
 270         my ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
 271
 272     if (!$tcn) {
 273             $xpath = '//marc:datafield[@tag="039"]/marc:subfield[@code="a"]';
 274             ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
 275     }
 276
 277         $xpath = '//marc:datafield[@tag="901"]/marc:subfield[@code="b"]';
 278         my ($tcn_source) = $marcxml->documentElement->findvalue($xpath);
 279     if (!$tcn_source) {
 280             $xpath = '//marc:datafield[@tag="039"]/marc:subfield[@code="b"]';
 281         $tcn_source = $marcxml->documentElement->findvalue($xpath) || "System Local";
 282     }
 283
 284         if(_tcn_exists($editor, $tcn, $tcn_source, $existing_rec)) {
 285                 $tcn = undef;
 286         }
 287
 288
 289         if(!$tcn) {
 290                 $xpath = '//marc:datafield[@tag="020"]/marc:subfield[@code="a"]';
 291                 ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
 292                 $tcn_source = "ISBN";
 293                 if(_tcn_exists($editor, $tcn, $tcn_source, $existing_rec)) {$tcn = undef;}
 294         }
 295
 296         if(!$tcn) {
 297                 $xpath = '//marc:datafield[@tag="022"]/marc:subfield[@code="a"]';
 298                 ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
 299                 $tcn_source = "ISSN";
 300                 if(_tcn_exists($editor, $tcn, $tcn_source, $existing_rec)) {$tcn = undef;}
 301         }
 302
 303         if(!$tcn) {
 304                 $xpath = '//marc:datafield[@tag="010"]';
 305                 ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
 306                 $tcn_source = "LCCN";
 307                 if(_tcn_exists($editor, $tcn, $tcn_source, $existing_rec)) {$tcn = undef;}
 308         }
 309
 310         if(!$tcn) {
 311                 $xpath = '//marc:datafield[@tag="035"]/marc:subfield[@code="a"]';
 312                 ($tcn) = $marcxml->documentElement->findvalue($xpath) =~ /(\w+)\s*$/o;
 313                 $tcn_source = "System Legacy";
 314                 if(_tcn_exists($editor, $tcn, $tcn_source, $existing_rec)) {$tcn = undef;}
 315
 316                 if($tcn) {
 317                         $marcxml->documentElement->removeChild(
 318                                 $marcxml->documentElement->findnodes( '//marc:datafield[@tag="035"]' )
 319                         );
 320                 }
 321         }
 322
 323         return undef unless $tcn;
 324         return $tcn;
 325 }
 326
 327
 328
 329 sub _tcn_exists {
 330         my $editor = shift;
 331         my $tcn = shift;
 332         my $source = shift;
 333         my $existing_rec = shift || 0;
 334
 335         if(!$tcn) {return 0;}
 336
 337         $logger->debug("tcn_exists search for tcn $tcn and source $source and id $existing_rec");
 338
 339         # XXX why does the source matter?
 340 #       my $req = $session->request(
 341 #               { tcn_value => $tcn, tcn_source => $source, deleted => 'f' } );
 342
 343     my $recs = $editor->search_biblio_record_entry(
 344         {tcn_value => $tcn, deleted => 'f', id => {'!=' => $existing_rec}}, {idlist =>1});
 345
 346         if(@$recs) {
 347                 $logger->debug("_tcn_exists is true for tcn : $tcn ($source)");
 348                 return $recs->[0];
 349         }
 350
 351         $logger->debug("_tcn_exists is false for tcn : $tcn ($source)");
 352         return 0;
 353 }
 354
 355
 356 sub delete_rec {
 357    my($class, $editor, $rec_id ) = @_;
 358
 359    my $rec = $editor->retrieve_biblio_record_entry($rec_id)
 360       or return $editor->event;
 361
 362    return undef if $U->is_true($rec->deleted);
 363
 364    $rec->deleted('t');
 365    $rec->active('f');
 366    $rec->editor( $editor->requestor->id );
 367    $rec->edit_date('now');
 368
 369    # Set the leader/05 to indicate that the record has been deleted
 370    my $marc = $rec->marc();
 371    $marc =~ s{(<leader>.{5}).}{$1d};
 372    $rec->marc($marc);
 373
 374    $editor->update_biblio_record_entry($rec) or return $editor->event;
 375
 376     my $holds = $editor->search_action_hold_request({
 377         target => $rec->id,
 378         hold_type => 'T',
 379         cancel_time => undef,
 380         fulfillment_time => undef
 381     });
 382
 383     for my $hold (@$holds) {
 384
 385         $hold->cancel_time('now');
 386         $hold->cancel_cause(1); # un-targeted expiration.
 387         $editor->update_action_hold_request($hold) or return $editor->die_event;
 388
 389         my $maps = $editor->search_action_hold_copy_map({hold => $hold->id});
 390         for(@$maps) {
 391             $editor->delete_action_hold_copy_map($_)
 392                 or return $editor->die_event;
 393         }
 394
 395         my $at_ses = OpenSRF::AppSession->create('open-ils.trigger');
 396         $at_ses->request(
 397             'open-ils.trigger.event.autocreate',
 398             'hold_request.cancel.expire_no_target',
 399             $hold, $hold->pickup_lib);
 400     }
 401
 402    return undef;
 403 }
 404
 405
 406 # ---------------------------------------------------------------------------
 407 # returns true if the given title (id) has no un-deleted volumes or
 408 # copies attached.  If a context volume is defined, a record
 409 # is considered empty only if the context volume is the only
 410 # remaining volume on the record.
 411 # ---------------------------------------------------------------------------
 412 sub title_is_empty {
 413         my($class, $editor, $rid, $vol_id) = @_;
 414
 415         return 0 if $rid == OILS_PRECAT_RECORD;
 416
 417         my $cnlist = $editor->search_asset_call_number(
 418                 { record => $rid, deleted => 'f' }, { idlist => 1 } );
 419
 420         return 1 unless @$cnlist; # no attached volumes
 421     return 0 if @$cnlist > 1; # multiple attached volumes
 422     return 0 unless $$cnlist[0] == $vol_id; # attached volume is not the context vol.
 423
 424     # see if the sole remaining context volume has any attached copies
 425         for my $cn (@$cnlist) {
 426                 my $copylist = $editor->search_asset_copy(
 427                         [
 428                                 { call_number => $cn, deleted => 'f' },
 429                                 { limit => 1 },
 430                         ], { idlist => 1 });
 431                 return 0 if @$copylist; # false if we find any copies
 432         }
 433
 434         return 1;
 435 }
 436 1;