C4/Biblio.pm

   1 package C4::Biblio;
   2
   3 # Copyright 2000-2002 Katipo Communications
   4 # Copyright 2010 BibLibre
   5 # Copyright 2011 Equinox Software, Inc.
   6 #
   7 # This file is part of Koha.
   8 #
   9 # Koha is free software; you can redistribute it and/or modify it
  10 # under the terms of the GNU General Public License as published by
  11 # the Free Software Foundation; either version 3 of the License, or
  12 # (at your option) any later version.
  13 #
  14 # Koha is distributed in the hope that it will be useful, but
  15 # WITHOUT ANY WARRANTY; without even the implied warranty of
  16 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  17 # GNU General Public License for more details.
  18 #
  19 # You should have received a copy of the GNU General Public License
  20 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  21
  22 use Modern::Perl;
  23
  24 use vars qw(@ISA @EXPORT_OK);
  25 BEGIN {
  26     require Exporter;
  27     @ISA = qw(Exporter);
  28
  29     @EXPORT_OK = qw(
  30         AddBiblio
  31         GetBiblioData
  32         GetISBDView
  33         GetMarcControlnumber
  34         GetMarcISBN
  35         GetMarcISSN
  36         GetMarcSubjects
  37         GetMarcSeries
  38         GetMarcUrls
  39         GetUsedMarcStructure
  40         GetXmlBiblio
  41         GetMarcPrice
  42         MungeMarcPrice
  43         GetMarcQuantity
  44         GetAuthorisedValueDesc
  45         GetMarcStructure
  46         GetMarcSubfieldStructure
  47         IsMarcStructureInternal
  48         GetMarcFromKohaField
  49         GetMarcSubfieldStructureFromKohaField
  50         GetFrameworkCode
  51         TransformKohaToMarc
  52         PrepHostMarcField
  53         CountItemsIssued
  54         ModBiblio
  55         ModZebra
  56         UpdateTotalIssues
  57         RemoveAllNsb
  58         DelBiblio
  59         BiblioAutoLink
  60         LinkBibHeadingsToAuthorities
  61         ApplyMarcOverlayRules
  62         TransformMarcToKoha
  63         TransformHtmlToMarc
  64         TransformHtmlToXml
  65         prepare_host_field
  66     );
  67
  68     # Internal functions
  69     # those functions are exported but should not be used
  70     # they are useful in a few circumstances, so they are exported,
  71     # but don't use them unless you are a core developer ;-)
  72     push @EXPORT_OK, qw(
  73       ModBiblioMarc
  74     );
  75 }
  76
  77 use Carp qw( carp );
  78 use Try::Tiny qw( catch try );
  79
  80 use Encode;
  81 use List::MoreUtils qw( uniq );
  82 use MARC::Record;
  83 use MARC::File::USMARC;
  84 use MARC::File::XML;
  85 use POSIX qw( strftime );
  86 use Module::Load::Conditional qw( can_load );
  87
  88 use C4::Koha;
  89 use C4::Log qw( logaction );    # logaction
  90 use C4::Budgets;
  91 use C4::ClassSource qw( GetClassSort GetClassSource );
  92 use C4::Charset qw(
  93     nsb_clean
  94     SetMarcUnicodeFlag
  95     SetUTF8Flag
  96     StripNonXmlChars
  97 );
  98 use C4::Languages;
  99 use C4::Linker;
 100 use C4::OAI::Sets;
 101 use C4::Items qw( GetMarcItem );
 102
 103 use Koha::Logger;
 104 use Koha::Caches;
 105 use Koha::ClassSources;
 106 use Koha::Authority::Types;
 107 use Koha::Acquisition::Currencies;
 108 use Koha::BackgroundJob::BatchUpdateBiblioHoldsQueue;
 109 use Koha::Biblio::Metadatas;
 110 use Koha::Holds;
 111 use Koha::ItemTypes;
 112 use Koha::MarcOverlayRules;
 113 use Koha::Plugins;
 114 use Koha::SearchEngine;
 115 use Koha::SearchEngine::Indexer;
 116 use Koha::Libraries;
 117 use Koha::Util::MARC;
 118
 119 =head1 NAME
 120
 121 C4::Biblio - cataloging management functions
 122
 123 =head1 DESCRIPTION
 124
 125 Biblio.pm contains functions for managing storage and editing of bibliographic data within Koha. Most of the functions in this module are used for cataloging records: adding, editing, or removing biblios, biblioitems, or items. Koha's stores bibliographic information in three places:
 126
 127 =over 4
 128
 129 =item 1. in the biblio,biblioitems,items, etc tables, which are limited to a one-to-one mapping to underlying MARC data
 130
 131 =item 2. as raw MARC in the Zebra index and storage engine
 132
 133 =item 3. as MARC XML in biblio_metadata.metadata
 134
 135 =back
 136
 137 In the 3.0 version of Koha, the authoritative record-level information is in biblio_metadata.metadata
 138
 139 Because the data isn't completely normalized there's a chance for information to get out of sync. The design choice to go with a un-normalized schema was driven by performance and stability concerns. However, if this occur, it can be considered as a bug : The API is (or should be) complete & the only entry point for all biblio/items managements.
 140
 141 =over 4
 142
 143 =item 1. Compared with MySQL, Zebra is slow to update an index for small data changes -- especially for proc-intensive operations like circulation
 144
 145 =item 2. Zebra's index has been known to crash and a backup of the data is necessary to rebuild it in such cases
 146
 147 =back
 148
 149 Because of this design choice, the process of managing storage and editing is a bit convoluted. Historically, Biblio.pm's grown to an unmanagable size and as a result we have several types of functions currently:
 150
 151 =over 4
 152
 153 =item 1. Add*/Mod*/Del*/ - high-level external functions suitable for being called from external scripts to manage the collection
 154
 155 =item 2. _koha_* - low-level internal functions for managing the koha tables
 156
 157 =item 3. Marc management function : as the MARC record is stored in biblio_metadata.metadata, some subs dedicated to it's management are in this package. They should be used only internally by Biblio.pm, the only official entry points being AddBiblio, AddItem, ModBiblio, ModItem.
 158
 159 =item 4. Zebra functions used to update the Zebra index
 160
 161 =item 5. internal helper functions such as char_decode, checkitems, etc. Some of these probably belong in Koha.pm
 162
 163 =back
 164
 165 The MARC record (in biblio_metadata.metadata) contains the complete marc record, including items. It also contains the biblionumber. That is the reason why it is not stored directly by AddBiblio, with all other fields . To save a biblio, we need to :
 166
 167 =over 4
 168
 169 =item 1. save datas in biblio and biblioitems table, that gives us a biblionumber and a biblioitemnumber
 170
 171 =item 2. add the biblionumber and biblioitemnumber into the MARC records
 172
 173 =item 3. save the marc record
 174
 175 =back
 176
 177 =head1 EXPORTED FUNCTIONS
 178
 179 =head2 AddBiblio
 180
 181   ($biblionumber,$biblioitemnumber) = AddBiblio($record,$frameworkcode);
 182
 183 Exported function (core API) for adding a new biblio to koha.
 184
 185 The first argument is a C<MARC::Record> object containing the
 186 bib to add, while the second argument is the desired MARC
 187 framework code.
 188
 189 The C<$options> argument is a hashref with additional parameters:
 190
 191 =over 4
 192
 193 =item B<defer_marc_save>: used when ModBiblioMarc is handled by the caller
 194
 195 =item B<skip_record_index>: used when the indexing schedulling will be handled by the caller
 196
 197 =back
 198
 199 =cut
 200
 201 sub AddBiblio {
 202     my ( $record, $frameworkcode, $options ) = @_;
 203
 204     $options //= {};
 205     my $skip_record_index = $options->{skip_record_index} || 0;
 206     my $defer_marc_save   = $options->{defer_marc_save}   || 0;
 207
 208     if (!$record) {
 209         carp('AddBiblio called with undefined record');
 210         return;
 211     }
 212
 213     my $schema = Koha::Database->schema;
 214     my ( $biblionumber, $biblioitemnumber );
 215     try {
 216         $schema->txn_do(sub {
 217
 218             # transform the data into koha-table style data
 219             SetUTF8Flag($record);
 220             my $olddata = TransformMarcToKoha({ record => $record, limit_table => 'no_items' });
 221
 222             my $biblio = Koha::Biblio->new(
 223                 {
 224                     frameworkcode => $frameworkcode,
 225                     author        => $olddata->{author},
 226                     title         => $olddata->{title},
 227                     subtitle      => $olddata->{subtitle},
 228                     medium        => $olddata->{medium},
 229                     part_number   => $olddata->{part_number},
 230                     part_name     => $olddata->{part_name},
 231                     unititle      => $olddata->{unititle},
 232                     notes         => $olddata->{notes},
 233                     serial        => $olddata->{serial},
 234                     seriestitle   => $olddata->{seriestitle},
 235                     copyrightdate => $olddata->{copyrightdate},
 236                     datecreated   => \'NOW()',
 237                     abstract      => $olddata->{abstract},
 238                 }
 239             )->store;
 240             $biblionumber = $biblio->biblionumber;
 241             Koha::Exceptions::ObjectNotCreated->throw unless $biblio;
 242
 243             my ($cn_sort) = GetClassSort( $olddata->{'biblioitems.cn_source'}, $olddata->{'cn_class'}, $olddata->{'cn_item'} );
 244             my $biblioitem = Koha::Biblioitem->new(
 245                 {
 246                     biblionumber          => $biblionumber,
 247                     volume                => $olddata->{volume},
 248                     number                => $olddata->{number},
 249                     itemtype              => $olddata->{itemtype},
 250                     isbn                  => $olddata->{isbn},
 251                     issn                  => $olddata->{issn},
 252                     publicationyear       => $olddata->{publicationyear},
 253                     publishercode         => $olddata->{publishercode},
 254                     volumedate            => $olddata->{volumedate},
 255                     volumedesc            => $olddata->{volumedesc},
 256                     collectiontitle       => $olddata->{collectiontitle},
 257                     collectionissn        => $olddata->{collectionissn},
 258                     collectionvolume      => $olddata->{collectionvolume},
 259                     editionstatement      => $olddata->{editionstatement},
 260                     editionresponsibility => $olddata->{editionresponsibility},
 261                     illus                 => $olddata->{illus},
 262                     pages                 => $olddata->{pages},
 263                     notes                 => $olddata->{bnotes},
 264                     size                  => $olddata->{size},
 265                     place                 => $olddata->{place},
 266                     lccn                  => $olddata->{lccn},
 267                     url                   => $olddata->{url},
 268                     cn_source      => $olddata->{'biblioitems.cn_source'},
 269                     cn_class       => $olddata->{cn_class},
 270                     cn_item        => $olddata->{cn_item},
 271                     cn_suffix      => $olddata->{cn_suff},
 272                     cn_sort        => $cn_sort,
 273                     totalissues    => $olddata->{totalissues},
 274                     ean            => $olddata->{ean},
 275                     agerestriction => $olddata->{agerestriction},
 276                 }
 277             )->store;
 278             Koha::Exceptions::ObjectNotCreated->throw unless $biblioitem;
 279             $biblioitemnumber = $biblioitem->biblioitemnumber;
 280
 281             _koha_marc_update_bib_ids( $record, $frameworkcode, $biblionumber, $biblioitemnumber );
 282
 283             # update MARC subfield that stores biblioitems.cn_sort
 284             _koha_marc_update_biblioitem_cn_sort( $record, $olddata, $frameworkcode );
 285
 286             if (C4::Context->preference('AutoLinkBiblios')) {
 287                 BiblioAutoLink( $record, $frameworkcode );
 288             }
 289
 290             # now add the record, don't index while we are in the transaction though
 291             ModBiblioMarc( $record, $biblionumber, { skip_record_index => 1 } ) unless $defer_marc_save;
 292
 293             # update OAI-PMH sets
 294             if(C4::Context->preference("OAI-PMH:AutoUpdateSets")) {
 295                 C4::OAI::Sets::UpdateOAISetsBiblio($biblionumber, $record);
 296             }
 297
 298             _after_biblio_action_hooks({ action => 'create', biblio_id => $biblionumber });
 299
 300             logaction( "CATALOGUING", "ADD", $biblionumber, "biblio" ) if C4::Context->preference("CataloguingLog");
 301
 302         });
 303         # We index now, after the transaction is committed
 304         unless ( $skip_record_index ) {
 305             my $indexer = Koha::SearchEngine::Indexer->new({ index => $Koha::SearchEngine::BIBLIOS_INDEX });
 306             $indexer->index_records( $biblionumber, "specialUpdate", "biblioserver" );
 307         }
 308     } catch {
 309         warn $_;
 310         ( $biblionumber, $biblioitemnumber ) = ( undef, undef );
 311     };
 312     return ( $biblionumber, $biblioitemnumber );
 313 }
 314
 315 =head2 ModBiblio
 316
 317   ModBiblio($record, $biblionumber, $frameworkcode, $options);
 318
 319 Replace an existing bib record identified by C<$biblionumber>
 320 with one supplied by the MARC::Record object C<$record>.  The embedded
 321 item, biblioitem, and biblionumber fields from the previous
 322 version of the bib record replace any such fields of those tags that
 323 are present in C<$record>.  Consequently, ModBiblio() is not
 324 to be used to try to modify item records.
 325
 326 C<$frameworkcode> specifies the MARC framework to use
 327 when storing the modified bib record; among other things,
 328 this controls how MARC fields get mapped to display columns
 329 in the C<biblio> and C<biblioitems> tables, as well as
 330 which fields are used to store embedded item, biblioitem,
 331 and biblionumber data for indexing.
 332
 333 The C<$options> argument is a hashref with additional parameters:
 334
 335 =over 4
 336
 337 =item C<overlay_context>
 338
 339 This parameter is forwarded to L</ApplyMarcOverlayRules> where it is used for
 340 selecting the current rule set if MARCOverlayRules is enabled.
 341 See L</ApplyMarcOverlayRules> for more details.
 342
 343 =item C<disable_autolink>
 344
 345 Unless C<disable_autolink> is passed ModBiblio will relink record headings
 346 to authorities based on settings in the system preferences. This flag allows
 347 us to not relink records when the authority linker is saving modifications.
 348
 349 =item C<skip_holds_queue>
 350
 351 Unless C<skip_holds_queue> is passed, ModBiblio will trigger the BatchUpdateBiblioHoldsQueue
 352 task to rebuild the holds queue for the biblio if I<RealTimeHoldsQueue> is enabled.
 353
 354 =back
 355
 356 Returns 1 on success 0 on failure
 357
 358 =cut
 359
 360 sub ModBiblio {
 361     my ( $record, $biblionumber, $frameworkcode, $options ) = @_;
 362
 363     $options //= {};
 364     my $skip_record_index = $options->{skip_record_index} || 0;
 365
 366     if (!$record) {
 367         carp 'No record passed to ModBiblio';
 368         return 0;
 369     }
 370
 371     if ( C4::Context->preference("CataloguingLog") ) {
 372         my $biblio = Koha::Biblios->find($biblionumber);
 373         logaction( "CATALOGUING", "MODIFY", $biblionumber, "biblio BEFORE=>" . $biblio->metadata->record->as_formatted );
 374     }
 375
 376     if ( !$options->{disable_autolink} && C4::Context->preference('AutoLinkBiblios') ) {
 377         BiblioAutoLink( $record, $frameworkcode );
 378     }
 379
 380     # Cleaning up invalid fields must be done early or SetUTF8Flag is liable to
 381     # throw an exception which probably won't be handled.
 382     foreach my $field ($record->fields()) {
 383         if (! $field->is_control_field()) {
 384             if (scalar($field->subfields()) == 0 || (scalar($field->subfields()) == 1 && $field->subfield('9'))) {
 385                 $record->delete_field($field);
 386             }
 387         }
 388     }
 389
 390     SetUTF8Flag($record);
 391     my $dbh = C4::Context->dbh;
 392
 393     $frameworkcode = "" if !$frameworkcode || $frameworkcode eq "Default"; # XXX
 394
 395     _strip_item_fields($record, $frameworkcode);
 396
 397     # apply overlay rules
 398     if (   C4::Context->preference('MARCOverlayRules')
 399         && $biblionumber
 400         && defined $options
 401         && exists $options->{overlay_context} )
 402     {
 403         $record = ApplyMarcOverlayRules(
 404             {
 405                 biblionumber    => $biblionumber,
 406                 record          => $record,
 407                 overlay_context => $options->{overlay_context},
 408             }
 409         );
 410     }
 411
 412     # update biblionumber and biblioitemnumber in MARC
 413     # FIXME - this is assuming a 1 to 1 relationship between
 414     # biblios and biblioitems
 415     my $sth = $dbh->prepare("select biblioitemnumber from biblioitems where biblionumber=?");
 416     $sth->execute($biblionumber);
 417     my ($biblioitemnumber) = $sth->fetchrow;
 418     $sth->finish();
 419     _koha_marc_update_bib_ids( $record, $frameworkcode, $biblionumber, $biblioitemnumber );
 420
 421     # load the koha-table data object
 422     my $oldbiblio = TransformMarcToKoha({ record => $record });
 423
 424     # update MARC subfield that stores biblioitems.cn_sort
 425     _koha_marc_update_biblioitem_cn_sort( $record, $oldbiblio, $frameworkcode );
 426
 427     # update the MARC record (that now contains biblio and items) with the new record data
 428     ModBiblioMarc( $record, $biblionumber, { skip_record_index => $skip_record_index } );
 429
 430     # modify the other koha tables
 431     _koha_modify_biblio( $dbh, $oldbiblio, $frameworkcode );
 432     _koha_modify_biblioitem_nonmarc( $dbh, $oldbiblio );
 433
 434     _after_biblio_action_hooks({ action => 'modify', biblio_id => $biblionumber });
 435
 436     # update OAI-PMH sets
 437     if(C4::Context->preference("OAI-PMH:AutoUpdateSets")) {
 438         C4::OAI::Sets::UpdateOAISetsBiblio($biblionumber, $record);
 439     }
 440
 441     Koha::BackgroundJob::BatchUpdateBiblioHoldsQueue->new->enqueue(
 442         {
 443             biblio_ids => [ $biblionumber ]
 444         }
 445     ) unless $options->{skip_holds_queue} or !C4::Context->preference('RealTimeHoldsQueue');
 446
 447     return 1;
 448 }
 449
 450 =head2 _strip_item_fields
 451
 452   _strip_item_fields($record, $frameworkcode)
 453
 454 Utility routine to remove item tags from a
 455 MARC bib.
 456
 457 =cut
 458
 459 sub _strip_item_fields {
 460     my $record = shift;
 461     my $frameworkcode = shift;
 462     # get the items before and append them to the biblio before updating the record, atm we just have the biblio
 463     my ( $itemtag, $itemsubfield ) = GetMarcFromKohaField( "items.itemnumber" );
 464
 465     # delete any item fields from incoming record to avoid
 466     # duplication or incorrect data - use AddItem() or ModItem()
 467     # to change items
 468     foreach my $field ( $record->field($itemtag) ) {
 469         $record->delete_field($field);
 470     }
 471 }
 472
 473 =head2 DelBiblio
 474
 475   my $error = &DelBiblio($biblionumber, $params);
 476
 477 Exported function (core API) for deleting a biblio in koha.
 478 Deletes biblio record from Zebra and Koha tables (biblio & biblioitems)
 479 Also backs it up to deleted* tables.
 480 Checks to make sure that the biblio has no items attached.
 481 return:
 482 C<$error> : undef unless an error occurs
 483
 484 I<$params> is a hashref containing extra parameters. Valid keys are:
 485
 486 =over 4
 487
 488 =item B<skip_holds_queue>: used when the holds queue update will be handled by the caller
 489
 490 =item B<skip_record_index>: used when the indexing schedulling will be handled by the caller
 491
 492 =back
 493 =cut
 494
 495 sub DelBiblio {
 496     my ($biblionumber, $params) = @_;
 497
 498     my $biblio = Koha::Biblios->find( $biblionumber );
 499     return unless $biblio; # Should we throw an exception instead?
 500
 501     my $dbh = C4::Context->dbh;
 502     my $error;    # for error handling
 503
 504     # First make sure this biblio has no items attached
 505     my $sth = $dbh->prepare("SELECT itemnumber FROM items WHERE biblionumber=?");
 506     $sth->execute($biblionumber);
 507     if ( my $itemnumber = $sth->fetchrow ) {
 508
 509         # Fix this to use a status the template can understand
 510         $error .= "This Biblio has items attached, please delete them first before deleting this biblio ";
 511     }
 512
 513     return $error if $error;
 514
 515     # We delete any existing holds
 516     my $holds = $biblio->holds;
 517     while ( my $hold = $holds->next ) {
 518         # no need to update the holds queue on each step, we'll do it at the end
 519         $hold->cancel({ skip_holds_queue => 1 });
 520     }
 521
 522     # We update any existing orders
 523     my $orders = $biblio->orders;
 524     $orders->update({ deleted_biblionumber => $biblionumber}, { no_triggers => 1 });
 525     # Update related ILL requests
 526     $biblio->ill_requests->update({ deleted_biblio_id => $biblio->id, biblio_id => undef });
 527
 528     unless ( $params->{skip_record_index} ){
 529         my $indexer = Koha::SearchEngine::Indexer->new({ index => $Koha::SearchEngine::BIBLIOS_INDEX });
 530         $indexer->index_records( $biblionumber, "recordDelete", "biblioserver" );
 531     }
 532
 533     # delete biblioitems and items from Koha tables and save in deletedbiblioitems,deleteditems
 534     $sth = $dbh->prepare("SELECT biblioitemnumber FROM biblioitems WHERE biblionumber=?");
 535     $sth->execute($biblionumber);
 536     while ( my $biblioitemnumber = $sth->fetchrow ) {
 537
 538         # delete this biblioitem
 539         $error = _koha_delete_biblioitems( $dbh, $biblioitemnumber );
 540         return $error if $error;
 541     }
 542
 543
 544     # delete biblio from Koha tables and save in deletedbiblio
 545     # must do this *after* _koha_delete_biblioitems, otherwise
 546     # delete cascade will prevent deletedbiblioitems rows
 547     # from being generated by _koha_delete_biblioitems
 548     $error = _koha_delete_biblio( $dbh, $biblionumber );
 549
 550     _after_biblio_action_hooks({ action => 'delete', biblio_id => $biblionumber });
 551
 552     logaction( "CATALOGUING", "DELETE", $biblionumber, "biblio" ) if C4::Context->preference("CataloguingLog");
 553
 554     Koha::BackgroundJob::BatchUpdateBiblioHoldsQueue->new->enqueue(
 555         {
 556             biblio_ids => [ $biblionumber ]
 557         }
 558     ) unless $params->{skip_holds_queue} or !C4::Context->preference('RealTimeHoldsQueue');
 559
 560     return;
 561 }
 562
 563
 564 =head2 BiblioAutoLink
 565
 566   my $headings_linked = BiblioAutoLink($record, $frameworkcode)
 567
 568 Automatically links headings in a bib record to authorities.
 569
 570 Returns the number of headings changed
 571
 572 =cut
 573
 574 sub BiblioAutoLink {
 575     my $record        = shift;
 576     my $frameworkcode = shift;
 577     my $verbose = shift;
 578     if (!$record) {
 579         carp('Undefined record passed to BiblioAutoLink');
 580         return 0;
 581     }
 582     my ( $num_headings_changed, %results );
 583
 584     my $linker_module =
 585       "C4::Linker::" . ( C4::Context->preference("LinkerModule") || 'Default' );
 586     unless ( can_load( modules => { $linker_module => undef } ) ) {
 587         $linker_module = 'C4::Linker::Default';
 588         unless ( can_load( modules => { $linker_module => undef } ) ) {
 589             return 0;
 590         }
 591     }
 592
 593     my $linker = $linker_module->new(
 594         { 'options' => C4::Context->preference("LinkerOptions") } );
 595     my ( $headings_changed, $results ) =
 596       LinkBibHeadingsToAuthorities( $linker, $record, $frameworkcode, C4::Context->preference("CatalogModuleRelink") || '', undef, $verbose );
 597     # By default we probably don't want to relink things when cataloging
 598     return $headings_changed, $results;
 599 }
 600
 601 =head2 LinkBibHeadingsToAuthorities
 602
 603   my $num_headings_changed, %results = LinkBibHeadingsToAuthorities($linker, $marc, $frameworkcode, [$allowrelink, $tagtolink,  $verbose]);
 604
 605 Links bib headings to authority records by checking
 606 each authority-controlled field in the C<MARC::Record>
 607 object C<$marc>, looking for a matching authority record,
 608 and setting the linking subfield $9 to the ID of that
 609 authority record.
 610
 611 If $allowrelink is false, existing authids will never be
 612 replaced, regardless of the values of LinkerKeepStale and
 613 LinkerRelink.
 614
 615 Returns the number of heading links changed in the
 616 MARC record.
 617
 618 =cut
 619
 620 sub LinkBibHeadingsToAuthorities {
 621     my $linker        = shift;
 622     my $bib           = shift;
 623     my $frameworkcode = shift;
 624     my $allowrelink = shift;
 625     my $tagtolink     = shift;
 626     my $verbose = shift;
 627     my %results;
 628     if (!$bib) {
 629         carp 'LinkBibHeadingsToAuthorities called on undefined bib record';
 630         return ( 0, {});
 631     }
 632     require C4::Heading;
 633     require C4::AuthoritiesMarc;
 634
 635     $allowrelink = 1 unless defined $allowrelink;
 636     my $num_headings_changed = 0;
 637     foreach my $field ( $bib->fields() ) {
 638         if ( defined $tagtolink ) {
 639           next unless $field->tag() == $tagtolink ;
 640         }
 641         my $heading = C4::Heading->new_from_field( $field, $frameworkcode );
 642         next unless defined $heading;
 643
 644         # check existing $9
 645         my $current_link = $field->subfield('9');
 646
 647         if ( defined $current_link && (!$allowrelink || !C4::Context->preference('LinkerRelink')) )
 648         {
 649             $results{'linked'}->{ $heading->display_form() }++;
 650             push(@{$results{'details'}}, { tag => $field->tag(), authid => $current_link, status => 'UNCHANGED'}) if $verbose;
 651             next;
 652         }
 653
 654         my ( $authid, $fuzzy, $match_count ) = $linker->get_link($heading);
 655         if ($authid) {
 656             $results{ $fuzzy ? 'fuzzy' : 'linked' }
 657               ->{ $heading->display_form() }++;
 658             if(defined $current_link and $current_link == $authid) {
 659                 push(@{$results{'details'}}, { tag => $field->tag(), authid => $current_link, status => 'UNCHANGED'}) if $verbose;
 660                 next;
 661             }
 662
 663             $field->delete_subfield( code => '9' ) if defined $current_link;
 664             $field->add_subfields( '9', $authid );
 665             $num_headings_changed++;
 666             push(@{$results{'details'}}, { tag => $field->tag(), authid => $authid, status => 'LOCAL_FOUND'}) if $verbose;
 667         }
 668         else {
 669             my $authority_type = Koha::Authority::Types->find( $heading->auth_type() );
 670             if ( defined $current_link
 671                 && (!$allowrelink || C4::Context->preference('LinkerKeepStale')) )
 672             {
 673                 $results{'fuzzy'}->{ $heading->display_form() }++;
 674                 push(@{$results{'details'}}, { tag => $field->tag(), authid => $current_link, status => 'UNCHANGED'}) if $verbose;
 675             }
 676             elsif ( C4::Context->preference('AutoCreateAuthorities') ) {
 677                 if ( _check_valid_auth_link( $current_link, $field ) ) {
 678                     $results{'linked'}->{ $heading->display_form() }++;
 679                 }
 680                 elsif ( !$match_count ) {
 681                     my $authority_type = Koha::Authority::Types->find( $heading->auth_type() );
 682                     my $marcrecordauth = MARC::Record->new();
 683                     if ( C4::Context->preference('marcflavour') eq 'MARC21' ) {
 684                         $marcrecordauth->leader('     nz  a22     o  4500');
 685                         SetMarcUnicodeFlag( $marcrecordauth, 'MARC21' );
 686                     }
 687                     $field->delete_subfield( code => '9' )
 688                       if defined $current_link;
 689                     my @auth_subfields;
 690                     foreach my $subfield ( $field->subfields() ){
 691                         if ( $subfield->[0] =~ /[A-z]/
 692                             && C4::Heading::valid_heading_subfield(
 693                                 $field->tag, $subfield->[0] )
 694                            ){
 695                             push @auth_subfields, $subfield->[0] => $subfield->[1];
 696                         }
 697                     }
 698                     # Bib headings contain some ending punctuation that should NOT
 699                     # be included in the authority record. Strip those before creation
 700                     next unless @auth_subfields; # Don't try to create a record if we have no fields;
 701                     my $last_sub = pop @auth_subfields;
 702                     $last_sub =~ s/[\s]*[,.:=;!%\/][\s]*$//;
 703                     push @auth_subfields, $last_sub;
 704                     my $authfield = MARC::Field->new( $authority_type->auth_tag_to_report, '', '', @auth_subfields );
 705                     $marcrecordauth->insert_fields_ordered($authfield);
 706
 707 # bug 2317: ensure new authority knows it's using UTF-8; currently
 708 # only need to do this for MARC21, as MARC::Record->as_xml_record() handles
 709 # automatically for UNIMARC (by not transcoding)
 710 # FIXME: AddAuthority() instead should simply explicitly require that the MARC::Record
 711 # use UTF-8, but as of 2008-08-05, did not want to introduce that kind
 712 # of change to a core API just before the 3.0 release.
 713
 714                     if ( C4::Context->preference('marcflavour') eq 'MARC21' ) {
 715                         my $userenv = C4::Context->userenv;
 716                         my $library;
 717                         if ( $userenv && $userenv->{'branch'} ) {
 718                             $library = Koha::Libraries->find( $userenv->{'branch'} );
 719                         }
 720                         $marcrecordauth->insert_fields_ordered(
 721                             MARC::Field->new(
 722                                 '667', '', '',
 723                                 'a' => C4::Context->preference('GenerateAuthorityField667')
 724                             )
 725                         );
 726                         my $cite =
 727                             $bib->author() . ", "
 728                           . $bib->title_proper() . ", "
 729                           . $bib->publication_date() . " ";
 730                         $cite =~ s/^[\s\,]*//;
 731                         $cite =~ s/[\s\,]*$//;
 732                         $cite =
 733                             C4::Context->preference('GenerateAuthorityField670') . ": ("
 734                           . ( $library ? $library->get_effective_marcorgcode : C4::Context->preference('MARCOrgCode') ) . ")"
 735                           . $bib->subfield( '999', 'c' ) . ": "
 736                           . $cite;
 737                         $marcrecordauth->insert_fields_ordered(
 738                             MARC::Field->new( '670', '', '', 'a' => $cite ) );
 739                     }
 740
 741            #          warn "AUTH RECORD ADDED : ".$marcrecordauth->as_formatted;
 742
 743                     $authid =
 744                       C4::AuthoritiesMarc::AddAuthority( $marcrecordauth, '',
 745                         $heading->auth_type() );
 746                     $field->add_subfields( '9', $authid );
 747                     $num_headings_changed++;
 748                     $linker->update_cache($heading, $authid);
 749                     $results{'added'}->{ $heading->display_form() }++;
 750                     push(@{$results{'details'}}, { tag => $field->tag(), authid => $authid, status => 'CREATED'}) if $verbose;
 751                 }
 752             }
 753             elsif ( defined $current_link ) {
 754                 if ( _check_valid_auth_link( $current_link, $field ) ) {
 755                     $results{'linked'}->{ $heading->display_form() }++;
 756                     push(@{$results{'details'}}, { tag => $field->tag(), authid => $authid, status => 'UNCHANGED'}) if $verbose;
 757                 }
 758                 else {
 759                     $field->delete_subfield( code => '9' );
 760                     $num_headings_changed++;
 761                     $results{'unlinked'}->{ $heading->display_form() }++;
 762                     push(@{$results{'details'}}, { tag => $field->tag(), authid => undef, status => 'NONE_FOUND', auth_type => $heading->auth_type(), tag_to_report => $authority_type->auth_tag_to_report}) if $verbose;
 763                 }
 764             }
 765             else {
 766                 $results{'unlinked'}->{ $heading->display_form() }++;
 767                 push(@{$results{'details'}}, { tag => $field->tag(), authid => undef, status => 'NONE_FOUND', auth_type => $heading->auth_type(), tag_to_report => $authority_type->auth_tag_to_report}) if $verbose;
 768             }
 769         }
 770
 771     }
 772     push(@{$results{'details'}}, { tag => '', authid => undef, status => 'UNCHANGED'}) unless %results;
 773     return $num_headings_changed, \%results;
 774 }
 775
 776 =head2 _check_valid_auth_link
 777
 778     if ( _check_valid_auth_link($authid, $field) ) {
 779         ...
 780     }
 781
 782 Check whether the specified heading-auth link is valid without reference
 783 to Zebra. Ideally this code would be in C4::Heading, but that won't be
 784 possible until we have de-cycled C4::AuthoritiesMarc, so this is the
 785 safest place.
 786
 787 =cut
 788
 789 sub _check_valid_auth_link {
 790     my ( $authid, $field ) = @_;
 791     require C4::AuthoritiesMarc;
 792
 793     return C4::AuthoritiesMarc::CompareFieldWithAuthority( { 'field' => $field, 'authid' => $authid } );
 794 }
 795
 796 =head2 GetBiblioData
 797
 798   $data = &GetBiblioData($biblionumber);
 799
 800 Returns information about the book with the given biblionumber.
 801 C<&GetBiblioData> returns a reference-to-hash. The keys are the fields in
 802 the C<biblio> and C<biblioitems> tables in the
 803 Koha database.
 804
 805 In addition, C<$data-E<gt>{subject}> is the list of the book's
 806 subjects, separated by C<" , "> (space, comma, space).
 807 If there are multiple biblioitems with the given biblionumber, only
 808 the first one is considered.
 809
 810 =cut
 811
 812 sub GetBiblioData {
 813     my ($bibnum) = @_;
 814     my $dbh = C4::Context->dbh;
 815
 816     my $query = " SELECT * , biblioitems.notes AS bnotes, itemtypes.notforloan as bi_notforloan, biblio.notes
 817             FROM biblio
 818             LEFT JOIN biblioitems ON biblio.biblionumber = biblioitems.biblionumber
 819             LEFT JOIN itemtypes ON biblioitems.itemtype = itemtypes.itemtype
 820             WHERE biblio.biblionumber = ?";
 821
 822     my $sth = $dbh->prepare($query);
 823     $sth->execute($bibnum);
 824     my $data;
 825     $data = $sth->fetchrow_hashref;
 826     $sth->finish;
 827
 828     return ($data);
 829 }    # sub GetBiblioData
 830
 831 =head2 GetISBDView
 832
 833   $isbd = &GetISBDView({
 834       'record'    => $marc_record,
 835       'template'  => $interface, # opac/intranet
 836       'framework' => $framework,
 837   });
 838
 839 Return the ISBD view which can be included in opac and intranet
 840
 841 =cut
 842
 843 sub GetISBDView {
 844     my ( $params ) = @_;
 845
 846     # Expecting record WITH items.
 847     my $record    = $params->{record};
 848     return unless defined $record;
 849
 850     my $template  = $params->{template} // q{};
 851     my $sysprefname = $template eq 'opac' ? 'opacisbd' : 'isbd';
 852     my $framework = $params->{framework};
 853     my $itemtype  = $framework;
 854     my ( $holdingbrtagf, $holdingbrtagsubf ) = &GetMarcFromKohaField( "items.holdingbranch" );
 855     my $tagslib = GetMarcStructure( 1, $itemtype, { unsafe => 1 } );
 856
 857     my $ISBD = C4::Context->preference($sysprefname);
 858     my $bloc = $ISBD;
 859     my $res;
 860     my $blocres;
 861
 862     foreach my $isbdfield ( split( /#/, $bloc ) ) {
 863
 864         #         $isbdfield= /(.?.?.?)/;
 865         $isbdfield =~ /(\d\d\d)([^\|])?\|(.*)\|(.*)\|(.*)/;
 866         my $fieldvalue = $1 || 0;
 867         my $subfvalue  = $2 || "";
 868         my $textbefore = $3;
 869         my $analysestring = $4;
 870         my $textafter     = $5;
 871
 872         #         warn "==> $1 / $2 / $3 / $4";
 873         #         my $fieldvalue=substr($isbdfield,0,3);
 874         if ( $fieldvalue > 0 ) {
 875             my $hasputtextbefore = 0;
 876             my @fieldslist       = $record->field($fieldvalue);
 877             @fieldslist = sort { $a->subfield($holdingbrtagsubf) cmp $b->subfield($holdingbrtagsubf) } @fieldslist if ( $fieldvalue eq $holdingbrtagf );
 878
 879             #         warn "ERROR IN ISBD DEFINITION at : $isbdfield" unless $fieldvalue;
 880             #             warn "FV : $fieldvalue";
 881             if ( $subfvalue ne "" ) {
 882                 # OPAC hidden subfield
 883                 next
 884                   if ( ( $template eq 'opac' )
 885                     && ( $tagslib->{$fieldvalue}->{$subfvalue}->{'hidden'} || 0 ) > 0 );
 886                 foreach my $field (@fieldslist) {
 887                     foreach my $subfield ( $field->subfield($subfvalue) ) {
 888                         my $calculated = $analysestring;
 889                         my $tag        = $field->tag();
 890                         if ( $tag < 10 ) {
 891                         } else {
 892                             my $subfieldvalue = GetAuthorisedValueDesc( $tag, $subfvalue, $subfield, '', $tagslib );
 893                             my $tagsubf = $tag . $subfvalue;
 894                             $calculated =~ s/\{(.?.?.?.?)$tagsubf(.*?)\}/$1$subfieldvalue$2\{$1$tagsubf$2\}/g;
 895                             if ( $template eq "opac" ) { $calculated =~ s#/cgi-bin/koha/[^/]+/([^.]*.pl\?.*)$#opac-$1#g; }
 896
 897                             # field builded, store the result
 898                             if ( $calculated && !$hasputtextbefore ) {    # put textbefore if not done
 899                                 $blocres .= $textbefore;
 900                                 $hasputtextbefore = 1;
 901                             }
 902
 903                             # remove punctuation at start
 904                             $calculated =~ s/^( |;|:|\.|-)*//g;
 905                             $blocres .= $calculated;
 906
 907                         }
 908                     }
 909                 }
 910                 $blocres .= $textafter if $hasputtextbefore;
 911             } else {
 912                 foreach my $field (@fieldslist) {
 913                     my $calculated = $analysestring;
 914                     my $tag        = $field->tag();
 915                     if ( $tag < 10 ) {
 916                     } else {
 917                         my @subf = $field->subfields;
 918                         for my $i ( 0 .. $#subf ) {
 919                             my $valuecode     = $subf[$i][1];
 920                             my $subfieldcode  = $subf[$i][0];
 921                             # OPAC hidden subfield
 922                             next
 923                               if ( ( $template eq 'opac' )
 924                                 && ( $tagslib->{$fieldvalue}->{$subfieldcode}->{'hidden'} || 0 ) > 0 );
 925                             my $subfieldvalue = GetAuthorisedValueDesc( $tag, $subf[$i][0], $subf[$i][1], '', $tagslib );
 926                             my $tagsubf       = $tag . $subfieldcode;
 927
 928                             $calculated =~ s/                  # replace all {{}} codes by the value code.
 929                                   \{\{$tagsubf\}\} # catch the {{actualcode}}
 930                                 /
 931                                   $valuecode     # replace by the value code
 932                                /gx;
 933
 934                             $calculated =~ s/\{(.?.?.?.?)$tagsubf(.*?)\}/$1$subfieldvalue$2\{$1$tagsubf$2\}/g;
 935                             if ( $template eq "opac" ) { $calculated =~ s#/cgi-bin/koha/[^/]+/([^.]*.pl\?.*)$#opac-$1#g; }
 936                         }
 937
 938                         # field builded, store the result
 939                         if ( $calculated && !$hasputtextbefore ) {    # put textbefore if not done
 940                             $blocres .= $textbefore;
 941                             $hasputtextbefore = 1;
 942                         }
 943
 944                         # remove punctuation at start
 945                         $calculated =~ s/^( |;|:|\.|-)*//g;
 946                         $blocres .= $calculated;
 947                     }
 948                 }
 949                 $blocres .= $textafter if $hasputtextbefore;
 950             }
 951         } else {
 952             $blocres .= $isbdfield;
 953         }
 954     }
 955     $res .= $blocres;
 956
 957     $res =~ s/\{(.*?)\}//g;
 958     $res =~ s/\\n/\n/g;
 959     $res =~ s/\n/<br\/>/g;
 960
 961     # remove empty ()
 962     $res =~ s/\(\)//g;
 963
 964     return $res;
 965 }
 966
 967 =head1 FUNCTIONS FOR HANDLING MARC MANAGEMENT
 968
 969 =head2 IsMarcStructureInternal
 970
 971     my $tagslib = C4::Biblio::GetMarcStructure();
 972     for my $tag ( sort keys %$tagslib ) {
 973         next unless $tag;
 974         for my $subfield ( sort keys %{ $tagslib->{$tag} } ) {
 975             next if IsMarcStructureInternal($tagslib->{$tag}{$subfield});
 976         }
 977         # Process subfield
 978     }
 979
 980 GetMarcStructure creates keys (lib, tab, mandatory, repeatable, important) for a display purpose.
 981 These different values should not be processed as valid subfields.
 982
 983 =cut
 984
 985 sub IsMarcStructureInternal {
 986     my ( $subfield ) = @_;
 987     return ref $subfield ? 0 : 1;
 988 }
 989
 990 =head2 GetMarcStructure
 991
 992   $res = GetMarcStructure($forlibrarian, $frameworkcode, [ $params ]);
 993
 994 Returns a reference to a big hash of hash, with the Marc structure for the given frameworkcode
 995 $forlibrarian  :if set to 1, the MARC descriptions are the librarians ones, otherwise it's the public (OPAC) ones
 996 $frameworkcode : the framework code to read
 997 $params allows you to pass { unsafe => 1 } for better performance.
 998
 999 Note: If you call GetMarcStructure with unsafe => 1, do not modify or
1000 even autovivify its contents. It is a cached/shared data structure. Your
1001 changes c/would be passed around in subsequent calls.
1002
1003 =cut
1004
1005 sub GetMarcStructure {
1006     my ( $forlibrarian, $frameworkcode, $params ) = @_;
1007     $frameworkcode = "" unless $frameworkcode;
1008
1009     $forlibrarian = $forlibrarian ? 1 : 0;
1010     my $unsafe = ($params && $params->{unsafe})? 1: 0;
1011     my $cache = Koha::Caches->get_instance();
1012     my $cache_key = "MarcStructure-$forlibrarian-$frameworkcode";
1013     my $cached = $cache->get_from_cache($cache_key, { unsafe => $unsafe });
1014     return $cached if $cached;
1015
1016     my $dbh = C4::Context->dbh;
1017     my $sth = $dbh->prepare(
1018         "SELECT tagfield,liblibrarian,libopac,mandatory,repeatable,important,ind1_defaultvalue,ind2_defaultvalue
1019         FROM marc_tag_structure
1020         WHERE frameworkcode=?
1021         ORDER BY tagfield"
1022     );
1023     $sth->execute($frameworkcode);
1024     my ( $liblibrarian, $libopac, $tag, $res, $mandatory, $repeatable, $important, $ind1_defaultvalue, $ind2_defaultvalue );
1025
1026     while ( ( $tag, $liblibrarian, $libopac, $mandatory, $repeatable, $important, $ind1_defaultvalue, $ind2_defaultvalue ) = $sth->fetchrow ) {
1027         $res->{$tag}->{lib}        = ( $forlibrarian or !$libopac ) ? $liblibrarian : $libopac;
1028         $res->{$tag}->{tab}        = "";
1029         $res->{$tag}->{mandatory}  = $mandatory;
1030         $res->{$tag}->{important}  = $important;
1031         $res->{$tag}->{repeatable} = $repeatable;
1032     $res->{$tag}->{ind1_defaultvalue} = $ind1_defaultvalue;
1033     $res->{$tag}->{ind2_defaultvalue} = $ind2_defaultvalue;
1034     }
1035
1036     my $mss = Koha::MarcSubfieldStructures->search( { frameworkcode => $frameworkcode } )->unblessed;
1037     for my $m (@$mss) {
1038         $res->{ $m->{tagfield} }->{ $m->{tagsubfield} } = {
1039             lib => ( $forlibrarian or !$m->{libopac} ) ? $m->{liblibrarian} : $m->{libopac},
1040             subfield => $m->{tagsubfield},
1041             %$m
1042         };
1043     }
1044
1045     $cache->set_in_cache($cache_key, $res);
1046     return $res;
1047 }
1048
1049 =head2 GetUsedMarcStructure
1050
1051 The same function as GetMarcStructure except it just takes field
1052 in tab 0-9. (used field)
1053
1054   my $results = GetUsedMarcStructure($frameworkcode);
1055
1056 C<$results> is a ref to an array which each case contains a ref
1057 to a hash which each keys is the columns from marc_subfield_structure
1058
1059 C<$frameworkcode> is the framework code.
1060
1061 =cut
1062
1063 sub GetUsedMarcStructure {
1064     my $frameworkcode = shift || '';
1065     my $query = q{
1066         SELECT *
1067         FROM   marc_subfield_structure
1068         WHERE   tab > -1
1069             AND frameworkcode = ?
1070         ORDER BY tagfield, display_order, tagsubfield
1071     };
1072     my $sth = C4::Context->dbh->prepare($query);
1073     $sth->execute($frameworkcode);
1074     return $sth->fetchall_arrayref( {} );
1075 }
1076
1077 =pod
1078
1079 =head2 GetMarcSubfieldStructure
1080
1081   my $structure = GetMarcSubfieldStructure($frameworkcode, [$params]);
1082
1083 Returns a reference to hash representing MARC subfield structure
1084 for framework with framework code C<$frameworkcode>, C<$params> is
1085 optional and may contain additional options.
1086
1087 =over 4
1088
1089 =item C<$frameworkcode>
1090
1091 The framework code.
1092
1093 =item C<$params>
1094
1095 An optional hash reference with additional options.
1096 The following options are supported:
1097
1098 =over 4
1099
1100 =item unsafe
1101
1102 Pass { unsafe => 1 } do disable cached object cloning,
1103 and instead get a shared reference, resulting in better
1104 performance (but care must be taken so that retured object
1105 is never modified).
1106
1107 Note: If you call GetMarcSubfieldStructure with unsafe => 1, do not modify or
1108 even autovivify its contents. It is a cached/shared data structure. Your
1109 changes would be passed around in subsequent calls.
1110
1111 =back
1112
1113 =back
1114
1115 =cut
1116
1117 sub GetMarcSubfieldStructure {
1118     my ( $frameworkcode, $params ) = @_;
1119
1120     $frameworkcode //= '';
1121
1122     my $cache     = Koha::Caches->get_instance();
1123     my $cache_key = "MarcSubfieldStructure-$frameworkcode";
1124     my $cached  = $cache->get_from_cache($cache_key, { unsafe => ($params && $params->{unsafe}) });
1125     return $cached if $cached;
1126
1127     my $dbh = C4::Context->dbh;
1128     # We moved to selectall_arrayref since selectall_hashref does not
1129     # keep duplicate mappings on kohafield (like place in 260 vs 264)
1130     my $subfield_aref = $dbh->selectall_arrayref( q|
1131         SELECT *
1132         FROM marc_subfield_structure
1133         WHERE frameworkcode = ?
1134         AND kohafield > ''
1135         ORDER BY frameworkcode, tagfield, display_order, tagsubfield
1136     |, { Slice => {} }, $frameworkcode );
1137     # Now map the output to a hash structure
1138     my $subfield_structure = {};
1139     foreach my $row ( @$subfield_aref ) {
1140         push @{ $subfield_structure->{ $row->{kohafield} }}, $row;
1141     }
1142     $cache->set_in_cache( $cache_key, $subfield_structure );
1143     return $subfield_structure;
1144 }
1145
1146 =head2 GetMarcFromKohaField
1147
1148     ( $field,$subfield ) = GetMarcFromKohaField( $kohafield );
1149     @fields = GetMarcFromKohaField( $kohafield );
1150     $field = GetMarcFromKohaField( $kohafield );
1151
1152     Returns the MARC fields & subfields mapped to $kohafield.
1153     Since the Default framework is considered as authoritative for such
1154     mappings, the former frameworkcode parameter is obsoleted.
1155
1156     In list context all mappings are returned; there can be multiple
1157     mappings. Note that in the above example you could miss a second
1158     mappings in the first call.
1159     In scalar context only the field tag of the first mapping is returned.
1160
1161 =cut
1162
1163 sub GetMarcFromKohaField {
1164     my ( $kohafield ) = @_;
1165     return unless $kohafield;
1166     # The next call uses the Default framework since it is AUTHORITATIVE
1167     # for all Koha to MARC mappings.
1168     my $mss = GetMarcSubfieldStructure( '', { unsafe => 1 } ); # Do not change framework
1169     my @retval;
1170     foreach( @{ $mss->{$kohafield} } ) {
1171         push @retval, $_->{tagfield}, $_->{tagsubfield};
1172     }
1173     return wantarray ? @retval : ( @retval ? $retval[0] : undef );
1174 }
1175
1176 =head2 GetMarcSubfieldStructureFromKohaField
1177
1178     my $str = GetMarcSubfieldStructureFromKohaField( $kohafield );
1179
1180     Returns marc subfield structure information for $kohafield.
1181     The Default framework is used, since it is authoritative for kohafield
1182     mappings.
1183     In list context returns a list of all hashrefs, since there may be
1184     multiple mappings. In scalar context the first hashref is returned.
1185
1186 =cut
1187
1188 sub GetMarcSubfieldStructureFromKohaField {
1189     my ( $kohafield ) = @_;
1190
1191     return unless $kohafield;
1192
1193     # The next call uses the Default framework since it is AUTHORITATIVE
1194     # for all Koha to MARC mappings.
1195     my $mss = GetMarcSubfieldStructure( '', { unsafe => 1 } ); # Do not change framework
1196     return unless $mss->{$kohafield};
1197     return wantarray ? @{$mss->{$kohafield}} : $mss->{$kohafield}->[0];
1198 }
1199
1200 =head2 GetXmlBiblio
1201
1202   my $marcxml = GetXmlBiblio($biblionumber);
1203
1204 Returns biblio_metadata.metadata/marcxml of the biblionumber passed in parameter.
1205 The XML should only contain biblio information (item information is no longer stored in marcxml field)
1206
1207 =cut
1208
1209 sub GetXmlBiblio {
1210     my ($biblionumber) = @_;
1211     my $dbh = C4::Context->dbh;
1212     return unless $biblionumber;
1213     my ($marcxml) = $dbh->selectrow_array(
1214         q|
1215         SELECT metadata
1216         FROM biblio_metadata
1217         WHERE biblionumber=?
1218             AND format='marcxml'
1219             AND `schema`=?
1220     |, undef, $biblionumber, C4::Context->preference('marcflavour')
1221     );
1222     return $marcxml;
1223 }
1224
1225 =head2 GetMarcPrice
1226
1227 return the prices in accordance with the Marc format.
1228
1229 returns 0 if no price found
1230 returns undef if called without a marc record or with
1231 an unrecognized marc format
1232
1233 =cut
1234
1235 sub GetMarcPrice {
1236     my ( $record, $marcflavour ) = @_;
1237     if (!$record) {
1238         carp 'GetMarcPrice called on undefined record';
1239         return;
1240     }
1241
1242     my @listtags;
1243     my $subfield;
1244
1245     if ( $marcflavour eq "MARC21" ) {
1246         @listtags = ('345', '020');
1247         $subfield="c";
1248     } elsif ( $marcflavour eq "UNIMARC" ) {
1249         @listtags = ('345', '010');
1250         $subfield="d";
1251     } else {
1252         return;
1253     }
1254
1255     for my $field ( $record->field(@listtags) ) {
1256         for my $subfield_value  ($field->subfield($subfield)){
1257             #check value
1258             $subfield_value = MungeMarcPrice( $subfield_value );
1259             return $subfield_value if ($subfield_value);
1260         }
1261     }
1262     return 0; # no price found
1263 }
1264
1265 =head2 MungeMarcPrice
1266
1267 Return the best guess at what the actual price is from a price field.
1268
1269 =cut
1270
1271 sub MungeMarcPrice {
1272     my ( $price ) = @_;
1273     return unless ( $price =~ m/\d/ ); ## No digits means no price.
1274     # Look for the currency symbol and the normalized code of the active currency, if it's there,
1275     my $active_currency = Koha::Acquisition::Currencies->get_active;
1276     my $symbol = $active_currency->symbol;
1277     my $isocode = $active_currency->isocode;
1278     $isocode = $active_currency->currency unless defined $isocode;
1279     my $localprice;
1280     if ( $symbol ) {
1281         my @matches =($price=~ /
1282             \s?
1283             (                          # start of capturing parenthesis
1284             (?:
1285             (?:[\p{Sc}\p{L}\/.]){1,4}  # any character from Currency signs or Letter Unicode categories or slash or dot                                              within 1 to 4 occurrences : call this whole block 'symbol block'
1286             |(?:\d+[\p{P}\s]?){1,4}    # or else at least one digit followed or not by a punctuation sign or whitespace,                                             all these within 1 to 4 occurrences : call this whole block 'digits block'
1287             )
1288             \s?\p{Sc}?\s?              # followed or not by a whitespace. \p{Sc}?\s? are for cases like '25$ USD'
1289             (?:
1290             (?:[\p{Sc}\p{L}\/.]){1,4}  # followed by same block as symbol block
1291             |(?:\d+[\p{P}\s]?){1,4}    # or by same block as digits block
1292             )
1293             \s?\p{L}{0,4}\s?           # followed or not by a whitespace. \p{L}{0,4}\s? are for cases like '$9.50 USD'
1294             )                          # end of capturing parenthesis
1295             (?:\p{P}|\z)               # followed by a punctuation sign or by the end of the string
1296             /gx);
1297
1298         if ( @matches ) {
1299             foreach ( @matches ) {
1300                 $localprice = $_ and last if index($_, $isocode)>=0;
1301             }
1302             if ( !$localprice ) {
1303                 foreach ( @matches ) {
1304                     $localprice = $_ and last if $_=~ /(^|[^\p{Sc}\p{L}\/])\Q$symbol\E([^\p{Sc}\p{L}\/]+\z|\z)/;
1305                 }
1306             }
1307         }
1308     }
1309     if ( $localprice ) {
1310         $price = $localprice;
1311     } else {
1312         ## Grab the first number in the string ( can use commas or periods for thousands separator and/or decimal separator )
1313         ( $price ) = $price =~ m/([\d\,\.]+[[\,\.]\d\d]?)/;
1314     }
1315     # eliminate symbol/isocode, space and any final dot from the string
1316     $price =~ s/[\p{Sc}\p{L}\/ ]|\.$//g;
1317     # remove comma,dot when used as separators from hundreds
1318     $price =~s/[\,\.](\d{3})/$1/g;
1319     # convert comma to dot to ensure correct display of decimals if existing
1320     $price =~s/,/./;
1321     return $price;
1322 }
1323
1324
1325 =head2 GetMarcQuantity
1326
1327 return the quantity of a book. Used in acquisition only, when importing a file an iso2709 from a bookseller
1328 Warning : this is not really in the marc standard. In Unimarc, Electre (the most widely used bookseller) use the 969$a
1329
1330 returns 0 if no quantity found
1331 returns undef if called without a marc record or with
1332 an unrecognized marc format
1333
1334 =cut
1335
1336 sub GetMarcQuantity {
1337     my ( $record, $marcflavour ) = @_;
1338     if (!$record) {
1339         carp 'GetMarcQuantity called on undefined record';
1340         return;
1341     }
1342
1343     my @listtags;
1344     my $subfield;
1345
1346     if ( $marcflavour eq "MARC21" ) {
1347         return 0
1348     } elsif ( $marcflavour eq "UNIMARC" ) {
1349         @listtags = ('969');
1350         $subfield="a";
1351     } else {
1352         return;
1353     }
1354
1355     for my $field ( $record->field(@listtags) ) {
1356         for my $subfield_value  ($field->subfield($subfield)){
1357             #check value
1358             if ($subfield_value) {
1359                  # in France, the cents separator is the , but sometimes, ppl use a .
1360                  # in this case, the price will be x100 when unformatted ! Replace the . by a , to get a proper price calculation
1361                 $subfield_value =~ s/\./,/ if C4::Context->preference("CurrencyFormat") eq "FR";
1362                 return $subfield_value;
1363             }
1364         }
1365     }
1366     return 0; # no price found
1367 }
1368
1369
1370 =head2 GetAuthorisedValueDesc
1371
1372   my $subfieldvalue =get_authorised_value_desc(
1373     $tag, $subf[$i][0],$subf[$i][1], '', $taglib, $category, $opac);
1374
1375 Retrieve the complete description for a given authorised value.
1376
1377 Now takes $category and $value pair too.
1378
1379   my $auth_value_desc =GetAuthorisedValueDesc(
1380     '','', 'DVD' ,'','','CCODE');
1381
1382 If the optional $opac parameter is set to a true value, displays OPAC
1383 descriptions rather than normal ones when they exist.
1384
1385 =cut
1386
1387 sub GetAuthorisedValueDesc {
1388     my ( $tag, $subfield, $value, $framework, $tagslib, $category, $opac ) = @_;
1389
1390     return q{} unless defined($value);
1391
1392     my $cache     = Koha::Caches->get_instance();
1393     my $cache_key;
1394     if ( !$category ) {
1395
1396         return $value unless defined $tagslib->{$tag}->{$subfield}->{'authorised_value'};
1397
1398         #---- branch
1399         if ( $tagslib->{$tag}->{$subfield}->{'authorised_value'} eq "branches" ) {
1400             $cache_key = "libraries:name";
1401             my $libraries = $cache->get_from_cache( $cache_key, { unsafe => 1 } );
1402             if ( !$libraries ) {
1403                 $libraries = {
1404                     map { $_->branchcode => $_->branchname }
1405                       Koha::Libraries->search( {},
1406                         { columns => [ 'branchcode', 'branchname' ] } )
1407                       ->as_list
1408                 };
1409                 $cache->set_in_cache($cache_key, $libraries);
1410             }
1411             return $libraries->{$value};
1412         }
1413
1414         #---- itemtypes
1415         if ( $tagslib->{$tag}->{$subfield}->{'authorised_value'} eq "itemtypes" ) {
1416             my $lang = C4::Languages::getlanguage;
1417             $lang //= 'en';
1418             $cache_key = 'itemtype:description:' . $lang;
1419             my $itypes = $cache->get_from_cache( $cache_key, { unsafe => 1 } );
1420             if ( !$itypes ) {
1421                 $itypes =
1422                   { map { $_->itemtype => $_->translated_description }
1423                       Koha::ItemTypes->search()->as_list };
1424                 $cache->set_in_cache( $cache_key, $itypes );
1425             }
1426             return $itypes->{$value};
1427         }
1428
1429         if ( $tagslib->{$tag}->{$subfield}->{'authorised_value'} eq "cn_source" ) {
1430             $cache_key = "cn_sources:description";
1431             my $cn_sources = $cache->get_from_cache( $cache_key, { unsafe => 1 } );
1432             if ( !$cn_sources ) {
1433                 $cn_sources = {
1434                     map { $_->cn_source => $_->description }
1435                       Koha::ClassSources->search( {},
1436                         { columns => [ 'cn_source', 'description' ] } )
1437                       ->as_list
1438                 };
1439                 $cache->set_in_cache($cache_key, $cn_sources);
1440             }
1441             return $cn_sources->{$value};
1442         }
1443
1444         #---- "true" authorized value
1445         $category = $tagslib->{$tag}->{$subfield}->{'authorised_value'};
1446     }
1447
1448     my $dbh = C4::Context->dbh;
1449     if ( $category ne "" ) {
1450         $cache_key = "AV_descriptions:" . $category;
1451         my $av_descriptions = $cache->get_from_cache( $cache_key, { unsafe => 1 } );
1452         if ( !$av_descriptions ) {
1453             $av_descriptions = {
1454                 map {
1455                     $_->authorised_value =>
1456                       { lib => $_->lib, lib_opac => $_->lib_opac }
1457                 } Koha::AuthorisedValues->search(
1458                     { category => $category },
1459                     {
1460                         columns => [ 'authorised_value', 'lib_opac', 'lib' ]
1461                     }
1462                 )->as_list
1463             };
1464             $cache->set_in_cache($cache_key, $av_descriptions);
1465         }
1466         return ( $opac && $av_descriptions->{$value}->{'lib_opac'} )
1467           ? $av_descriptions->{$value}->{'lib_opac'}
1468           : $av_descriptions->{$value}->{'lib'};
1469     } else {
1470         return $value;    # if nothing is found return the original value
1471     }
1472 }
1473
1474 =head2 GetMarcControlnumber
1475
1476   $marccontrolnumber = GetMarcControlnumber($record,$marcflavour);
1477
1478 Get the control number / record Identifier from the MARC record and return it.
1479
1480 =cut
1481
1482 sub GetMarcControlnumber {
1483     my ( $record, $marcflavour ) = @_;
1484     if (!$record) {
1485         carp 'GetMarcControlnumber called on undefined record';
1486         return;
1487     }
1488     my $controlnumber = "";
1489     # Control number or Record identifier are the same field in MARC21 and UNIMARC
1490     # Keep $marcflavour for possible later use
1491     if ($marcflavour eq "MARC21" || $marcflavour eq "UNIMARC" ) {
1492         my $controlnumberField = $record->field('001');
1493         if ($controlnumberField) {
1494             $controlnumber = $controlnumberField->data();
1495         }
1496     }
1497     return $controlnumber;
1498 }
1499
1500 =head2 GetMarcISBN
1501
1502   $marcisbnsarray = GetMarcISBN( $record, $marcflavour );
1503
1504 Get all ISBNs from the MARC record and returns them in an array.
1505 ISBNs stored in different fields depending on MARC flavour
1506
1507 =cut
1508
1509 sub GetMarcISBN {
1510     my ( $record, $marcflavour ) = @_;
1511     if (!$record) {
1512         carp 'GetMarcISBN called on undefined record';
1513         return;
1514     }
1515     my $scope;
1516     if ( $marcflavour eq "UNIMARC" ) {
1517         $scope = '010';
1518     } else {    # assume marc21 if not unimarc
1519         $scope = '020';
1520     }
1521
1522     my @marcisbns;
1523     foreach my $field ( $record->field($scope) ) {
1524         my $isbn = $field->subfield( 'a' );
1525         if ( $isbn && $isbn ne "" ) {
1526             push @marcisbns, $isbn;
1527         }
1528     }
1529
1530     return \@marcisbns;
1531 }    # end GetMarcISBN
1532
1533
1534 =head2 GetMarcISSN
1535
1536   $marcissnsarray = GetMarcISSN( $record, $marcflavour );
1537
1538 Get all valid ISSNs from the MARC record and returns them in an array.
1539 ISSNs are stored in different fields depending on MARC flavour
1540
1541 =cut
1542
1543 sub GetMarcISSN {
1544     my ( $record, $marcflavour ) = @_;
1545     if (!$record) {
1546         carp 'GetMarcISSN called on undefined record';
1547         return;
1548     }
1549     my $scope;
1550     if ( $marcflavour eq "UNIMARC" ) {
1551         $scope = '011';
1552     }
1553     else {    # assume MARC21
1554         $scope = '022';
1555     }
1556     my @marcissns;
1557     foreach my $field ( $record->field($scope) ) {
1558         push @marcissns, $field->subfield( 'a' )
1559             if ( $field->subfield( 'a' ) ne "" );
1560     }
1561     return \@marcissns;
1562 }    # end GetMarcISSN
1563
1564 =head2 GetMarcSubjects
1565
1566   $marcsubjcts = GetMarcSubjects($record,$marcflavour);
1567
1568 Get all subjects from the MARC record and returns them in an array.
1569 The subjects are stored in different fields depending on MARC flavour
1570
1571 =cut
1572
1573 sub GetMarcSubjects {
1574     my ( $record, $marcflavour ) = @_;
1575     if (!$record) {
1576         carp 'GetMarcSubjects called on undefined record';
1577         return;
1578     }
1579     my ( $mintag, $maxtag, $fields_filter );
1580     if ( $marcflavour eq "UNIMARC" ) {
1581         $mintag = "600";
1582         $maxtag = "611";
1583         $fields_filter = '6..';
1584     } else { # marc21
1585         $mintag = "600";
1586         $maxtag = "699";
1587         $fields_filter = '6..';
1588     }
1589
1590     my @marcsubjects;
1591
1592     my $subject_limit = C4::Context->preference("TraceCompleteSubfields") ? 'su,complete-subfield' : 'su';
1593     my $AuthoritySeparator = C4::Context->preference('AuthoritySeparator');
1594
1595     foreach my $field ( $record->field($fields_filter) ) {
1596         next unless ($field->tag() >= $mintag && $field->tag() <= $maxtag);
1597         my @subfields_loop;
1598         my @subfields = $field->subfields();
1599         my @link_loop;
1600
1601         # if there is an authority link, build the links with an= subfield9
1602         my $subfield9 = $field->subfield('9');
1603         my $authoritylink;
1604         if ($subfield9) {
1605             my $linkvalue = $subfield9;
1606             $linkvalue =~ s/(\(|\))//g;
1607             @link_loop = ( { limit => 'an', 'link' => $linkvalue } );
1608             $authoritylink = $linkvalue
1609         }
1610
1611         # other subfields
1612         for my $subject_subfield (@subfields) {
1613             next if ( $subject_subfield->[0] eq '9' );
1614
1615             # don't load unimarc subfields 3,4,5
1616             next if ( ( $marcflavour eq "UNIMARC" ) and ( $subject_subfield->[0] =~ /2|3|4|5/ ) );
1617             # don't load MARC21 subfields 2 (FIXME: any more subfields??)
1618             next if ( ( $marcflavour eq "MARC21" ) and ( $subject_subfield->[0] =~ /2/ ) );
1619
1620             my $code      = $subject_subfield->[0];
1621             my $value     = $subject_subfield->[1];
1622             my $linkvalue = $value;
1623             $linkvalue =~ s/(\(|\))//g;
1624             # if no authority link, build a search query
1625             unless ($subfield9) {
1626                 push @link_loop, {
1627                     limit    => $subject_limit,
1628                     'link'   => $linkvalue,
1629                     operator => (scalar @link_loop) ? ' AND ' : undef
1630                 };
1631             }
1632             my @this_link_loop = @link_loop;
1633             # do not display $0
1634             unless ( $code eq '0' ) {
1635                 push @subfields_loop, {
1636                     code      => $code,
1637                     value     => $value,
1638                     link_loop => \@this_link_loop,
1639                     separator => (scalar @subfields_loop) ? $AuthoritySeparator : ''
1640                 };
1641             }
1642         }
1643
1644         push @marcsubjects, {
1645             MARCSUBJECT_SUBFIELDS_LOOP => \@subfields_loop,
1646             authoritylink => $authoritylink,
1647         } if $authoritylink || @subfields_loop;
1648
1649     }
1650     return \@marcsubjects;
1651 }    #end getMARCsubjects
1652
1653 =head2 GetMarcUrls
1654
1655   $marcurls = GetMarcUrls($record,$marcflavour);
1656
1657 Returns arrayref of URLs from MARC data, suitable to pass to tmpl loop.
1658 Assumes web resources (not uncommon in MARC21 to omit resource type ind)
1659
1660 =cut
1661
1662 sub GetMarcUrls {
1663     my ( $record, $marcflavour ) = @_;
1664     if (!$record) {
1665         carp 'GetMarcUrls called on undefined record';
1666         return;
1667     }
1668
1669     my @marcurls;
1670     for my $field ( $record->field('856') ) {
1671         my @notes;
1672         for my $note ( $field->subfield('z') ) {
1673             push @notes, { note => $note };
1674         }
1675         my @urls = $field->subfield('u');
1676         foreach my $url (@urls) {
1677             $url =~ s/^\s+|\s+$//g; # trim
1678             my $marcurl;
1679             if ( $marcflavour eq 'MARC21' ) {
1680                 my $s3   = $field->subfield('3');
1681                 my $link = $field->subfield('y');
1682                 unless ( $url =~ /^\w+:/ ) {
1683                     if ( $field->indicator(1) eq '7' ) {
1684                         $url = $field->subfield('2') . "://" . $url;
1685                     } elsif ( $field->indicator(1) eq '1' ) {
1686                         $url = 'ftp://' . $url;
1687                     } else {
1688
1689                         #  properly, this should be if ind1=4,
1690                         #  however we will assume http protocol since we're building a link.
1691                         $url = 'http://' . $url;
1692                     }
1693                 }
1694
1695                 # TODO handle ind 2 (relationship)
1696                 $marcurl = {
1697                     MARCURL => $url,
1698                     notes   => \@notes,
1699                 };
1700                 $marcurl->{'linktext'} = $link || $s3 || C4::Context->preference('URLLinkText') || $url;
1701                 $marcurl->{'part'} = $s3 if ($link);
1702                 $marcurl->{'toc'} = 1 if ( defined($s3) && $s3 =~ /^[Tt]able/ );
1703             } else {
1704                 $marcurl->{'linktext'} = $field->subfield('2') || C4::Context->preference('URLLinkText') || $url;
1705                 $marcurl->{'MARCURL'} = $url;
1706             }
1707             push @marcurls, $marcurl;
1708         }
1709     }
1710     return \@marcurls;
1711 }
1712
1713 =head2 GetMarcSeries
1714
1715   $marcseriesarray = GetMarcSeries($record,$marcflavour);
1716
1717 Get all series from the MARC record and returns them in an array.
1718 The series are stored in different fields depending on MARC flavour
1719
1720 =cut
1721
1722 sub GetMarcSeries {
1723     my ( $record, $marcflavour ) = @_;
1724     if (!$record) {
1725         carp 'GetMarcSeries called on undefined record';
1726         return;
1727     }
1728
1729     my ( $mintag, $maxtag, $fields_filter );
1730     if ( $marcflavour eq "UNIMARC" ) {
1731         $mintag = "225";
1732         $maxtag = "225";
1733         $fields_filter = '2..';
1734     } else {    # marc21
1735         $mintag = "440";
1736         $maxtag = "490";
1737         $fields_filter = '4..';
1738     }
1739
1740     my @marcseries;
1741     my $AuthoritySeparator = C4::Context->preference('AuthoritySeparator');
1742
1743     foreach my $field ( $record->field($fields_filter) ) {
1744         next unless $field->tag() >= $mintag && $field->tag() <= $maxtag;
1745         my @subfields_loop;
1746         my @subfields = $field->subfields();
1747         my @link_loop;
1748
1749         for my $series_subfield (@subfields) {
1750
1751             # ignore $9, used for authority link
1752             next if ( $series_subfield->[0] eq '9' );
1753
1754             my $volume_number;
1755             my $code      = $series_subfield->[0];
1756             my $value     = $series_subfield->[1];
1757             my $linkvalue = $value;
1758             $linkvalue =~ s/(\(|\))//g;
1759
1760             # see if this is an instance of a volume
1761             if ( $code eq 'v' ) {
1762                 $volume_number = 1;
1763             }
1764
1765             push @link_loop, {
1766                 'link' => $linkvalue,
1767                 operator => (scalar @link_loop) ? ' AND ' : undef
1768             };
1769
1770             if ($volume_number) {
1771                 push @subfields_loop, { volumenum => $value };
1772             } else {
1773                 push @subfields_loop, {
1774                     code      => $code,
1775                     value     => $value,
1776                     link_loop => \@link_loop,
1777                     separator => (scalar @subfields_loop) ? $AuthoritySeparator : '',
1778                     volumenum => $volume_number,
1779                 }
1780             }
1781         }
1782         push @marcseries, { MARCSERIES_SUBFIELDS_LOOP => \@subfields_loop };
1783
1784     }
1785     return \@marcseries;
1786 }    #end getMARCseriess
1787
1788 =head2 UpsertMarcSubfield
1789
1790     my $record = C4::Biblio::UpsertMarcSubfield($MARC::Record, $fieldTag, $subfieldCode, $subfieldContent);
1791
1792 =cut
1793
1794 sub UpsertMarcSubfield {
1795     my ($record, $tag, $code, $content) = @_;
1796     my $f = $record->field($tag);
1797
1798     if ($f) {
1799         $f->update( $code => $content );
1800     }
1801     else {
1802         my $f = MARC::Field->new( $tag, '', '', $code => $content);
1803         $record->insert_fields_ordered( $f );
1804     }
1805 }
1806
1807 =head2 UpsertMarcControlField
1808
1809     my $record = C4::Biblio::UpsertMarcControlField($MARC::Record, $fieldTag, $content);
1810
1811 =cut
1812
1813 sub UpsertMarcControlField {
1814     my ($record, $tag, $content) = @_;
1815     die "UpsertMarcControlField() \$tag '$tag' is not a control field\n" unless 0+$tag < 10;
1816     my $f = $record->field($tag);
1817
1818     if ($f) {
1819         $f->update( $content );
1820     }
1821     else {
1822         my $f = MARC::Field->new($tag, $content);
1823         $record->insert_fields_ordered( $f );
1824     }
1825 }
1826
1827 =head2 GetFrameworkCode
1828
1829   $frameworkcode = GetFrameworkCode( $biblionumber )
1830
1831 =cut
1832
1833 sub GetFrameworkCode {
1834     my ($biblionumber) = @_;
1835     my $cache          = Koha::Cache::Memory::Lite->get_instance();
1836     my $cache_key      = "FrameworkCode-$biblionumber";
1837     my $frameworkcode  = $cache->get_from_cache($cache_key);
1838     unless ( defined $frameworkcode ) {
1839         my $dbh = C4::Context->dbh;
1840         ($frameworkcode) = $dbh->selectrow_array(
1841             "SELECT frameworkcode FROM biblio WHERE biblionumber=?",
1842             undef, $biblionumber );
1843         $cache->set_in_cache( $cache_key, $frameworkcode );
1844     }
1845     return $frameworkcode;
1846 }
1847
1848 =head2 TransformKohaToMarc
1849
1850     $record = TransformKohaToMarc( $hash [, $params ]  )
1851
1852 This function builds a (partial) MARC::Record from a hash.
1853 Hash entries can be from biblio, biblioitems or items.
1854 The params hash includes the parameter no_split used in C4::Items.
1855
1856 This function is called in acquisition module, to create a basic catalogue
1857 entry from user entry.
1858
1859 =cut
1860
1861
1862 sub TransformKohaToMarc {
1863     my ( $hash, $params ) = @_;
1864     my $record = MARC::Record->new();
1865     SetMarcUnicodeFlag( $record, C4::Context->preference("marcflavour") );
1866
1867     # In the next call we use the Default framework, since it is considered
1868     # authoritative for Koha to Marc mappings.
1869     my $mss = GetMarcSubfieldStructure( '', { unsafe => 1 } ); # do not change framework
1870     my $tag_hr = {};
1871     while ( my ($kohafield, $value) = each %$hash ) {
1872         foreach my $fld ( @{ $mss->{$kohafield} } ) {
1873             my $tagfield    = $fld->{tagfield};
1874             my $tagsubfield = $fld->{tagsubfield};
1875             next if !$tagfield;
1876
1877             # BZ 21800: split value if field is repeatable.
1878             my @values = _check_split($params, $fld, $value)
1879                 ? split(/\s?\|\s?/, $value, -1)
1880                 : ( $value );
1881             foreach my $value ( @values ) {
1882                 next if $value eq '';
1883                 $tag_hr->{$tagfield} //= [];
1884                 push @{$tag_hr->{$tagfield}}, [($tagsubfield, $value)];
1885             }
1886         }
1887     }
1888     foreach my $tag (sort keys %$tag_hr) {
1889         my @sfl = @{$tag_hr->{$tag}};
1890         @sfl = sort { $a->[0] cmp $b->[0]; } @sfl;
1891         @sfl = map { @{$_}; } @sfl;
1892         # Special care for control fields: remove the subfield indication @
1893         # and do not insert indicators.
1894         my @ind = $tag < 10 ? () : ( " ", " " );
1895         @sfl = grep { $_ ne '@' } @sfl if $tag < 10;
1896         $record->insert_fields_ordered( MARC::Field->new($tag, @ind, @sfl) );
1897     }
1898     return $record;
1899 }
1900
1901 sub _check_split {
1902 # Checks if $value must be split; may consult passed framework
1903     my ($params, $fld, $value) = @_;
1904     return if index($value,'|') == -1; # nothing to worry about
1905     return if $params->{no_split};
1906
1907     # if we did not get a specific framework, check default in $mss
1908     return $fld->{repeatable} if !$params->{framework};
1909
1910     # here we need to check the specific framework
1911     my $mss = GetMarcSubfieldStructure($params->{framework}, { unsafe => 1 });
1912     foreach my $fld2 ( @{ $mss->{ $fld->{kohafield} } } ) {
1913         next if $fld2->{tagfield} ne $fld->{tagfield};
1914         next if $fld2->{tagsubfield} ne $fld->{tagsubfield};
1915         return 1 if $fld2->{repeatable};
1916     }
1917     return;
1918 }
1919
1920 =head2 PrepHostMarcField
1921
1922     $hostfield = PrepHostMarcField ( $hostbiblionumber,$hostitemnumber,$marcflavour )
1923
1924 This function returns a host field populated with data from the host record, the field can then be added to an analytical record
1925
1926 =cut
1927
1928 sub PrepHostMarcField {
1929     my ($hostbiblionumber,$hostitemnumber, $marcflavour) = @_;
1930     $marcflavour ||="MARC21";
1931
1932     my $biblio = Koha::Biblios->find($hostbiblionumber);
1933     my $hostrecord = $biblio->metadata->record;
1934     my $item = Koha::Items->find($hostitemnumber);
1935
1936         my $hostmarcfield;
1937     if ( $marcflavour eq "MARC21" ) {
1938
1939         #main entry
1940         my $mainentry;
1941         if ($hostrecord->subfield('100','a')){
1942             $mainentry = $hostrecord->subfield('100','a');
1943         } elsif ($hostrecord->subfield('110','a')){
1944             $mainentry = $hostrecord->subfield('110','a');
1945         } else {
1946             $mainentry = $hostrecord->subfield('111','a');
1947         }
1948
1949         # qualification info
1950         my $qualinfo;
1951         if (my $field260 = $hostrecord->field('260')){
1952             $qualinfo =  $field260->as_string( 'abc' );
1953         }
1954
1955
1956         #other fields
1957         my $ed = $hostrecord->subfield('250','a');
1958         my $barcode = $item->barcode;
1959         my $title = $hostrecord->subfield('245','a');
1960
1961         # record control number, 001 with 003 and prefix
1962         my $recctrlno;
1963         if ($hostrecord->field('001')){
1964             $recctrlno = $hostrecord->field('001')->data();
1965             if ($hostrecord->field('003')){
1966                 $recctrlno = '('.$hostrecord->field('003')->data().')'.$recctrlno;
1967             }
1968         }
1969
1970         # issn/isbn
1971         my $issn = $hostrecord->subfield('022','a');
1972         my $isbn = $hostrecord->subfield('020','a');
1973
1974
1975         $hostmarcfield = MARC::Field->new(
1976                 773, '0', '',
1977                 '0' => $hostbiblionumber,
1978                 '9' => $hostitemnumber,
1979                 'a' => $mainentry,
1980                 'b' => $ed,
1981                 'd' => $qualinfo,
1982                 'o' => $barcode,
1983                 't' => $title,
1984                 'w' => $recctrlno,
1985                 'x' => $issn,
1986                 'z' => $isbn
1987                 );
1988     } elsif ($marcflavour eq "UNIMARC") {
1989         $hostmarcfield = MARC::Field->new(
1990             461, '', '',
1991             '0' => $hostbiblionumber,
1992             't' => $hostrecord->subfield('200','a'),
1993             '9' => $hostitemnumber
1994         );
1995     };
1996
1997     return $hostmarcfield;
1998 }
1999
2000 =head2 TransformHtmlToXml
2001
2002   $xml = TransformHtmlToXml( $tags, $subfields, $values, $indicator,
2003                              $ind_tag, $auth_type )
2004
2005 $auth_type contains :
2006
2007 =over
2008
2009 =item - nothing : rebuild a biblio. In UNIMARC the encoding is in 100$a pos 26/27
2010
2011 =item - UNIMARCAUTH : rebuild an authority. In UNIMARC, the encoding is in 100$a pos 13/14
2012
2013 =item - ITEM : rebuild an item : in UNIMARC, 100$a, it's in the biblio ! (otherwise, we would get 2 100 fields !)
2014
2015 =back
2016
2017 =cut
2018
2019 sub TransformHtmlToXml {
2020     my ( $tags, $subfields, $values, $indicator, $ind_tag, $auth_type ) = @_;
2021     # NOTE: The parameter $ind_tag is NOT USED -- BZ 11247
2022
2023     my ( $perm_loc_tag, $perm_loc_subfield ) = C4::Biblio::GetMarcFromKohaField( "items.permanent_location" );
2024
2025     my $xml = MARC::File::XML::header('UTF-8');
2026     $xml .= "<record>\n";
2027     $auth_type = C4::Context->preference('marcflavour') unless $auth_type; # FIXME auth_type must be removed
2028     MARC::File::XML->default_record_format($auth_type);
2029
2030     # in UNIMARC, field 100 contains the encoding
2031     # check that there is one, otherwise the
2032     # MARC::Record->new_from_xml will fail (and Koha will die)
2033     my $unimarc_and_100_exist = 0;
2034     $unimarc_and_100_exist = 1 if $auth_type eq 'ITEM';    # if we rebuild an item, no need of a 100 field
2035     my $prevtag = -1;
2036     my $first   = 1;
2037     my $j       = -1;
2038     my $close_last_tag;
2039     for ( my $i = 0 ; $i < @$tags ; $i++ ) {
2040         if ( C4::Context->preference('marcflavour') eq 'UNIMARC' and @$tags[$i] eq "100" and @$subfields[$i] eq "a" ) {
2041
2042             # if we have a 100 field and it's values are not correct, skip them.
2043             # if we don't have any valid 100 field, we will create a default one at the end
2044             my $enc = substr( @$values[$i], 26, 2 );
2045             if ( $enc eq '01' or $enc eq '50' or $enc eq '03' ) {
2046                 $unimarc_and_100_exist = 1;
2047             } else {
2048                 next;
2049             }
2050         }
2051         @$values[$i] =~ s/&/&amp;/g;
2052         @$values[$i] =~ s/</&lt;/g;
2053         @$values[$i] =~ s/>/&gt;/g;
2054         @$values[$i] =~ s/"/&quot;/g;
2055         @$values[$i] =~ s/'/&apos;/g;
2056
2057         my $skip = @$values[$i] eq q{};
2058         $skip = 0
2059           if $perm_loc_tag
2060           && $perm_loc_subfield
2061           && @$tags[$i] eq $perm_loc_tag
2062           && @$subfields[$i] eq $perm_loc_subfield;
2063
2064         if ( ( @$tags[$i] ne $prevtag ) ) {
2065             $close_last_tag = 0;
2066             $j++ unless ( @$tags[$i] eq "" );
2067             my $str = ( $indicator->[$j] // q{} ) . '  '; # extra space prevents substr outside of string warn
2068             my $ind1 = _default_ind_to_space( substr( $str, 0, 1 ) );
2069             my $ind2 = _default_ind_to_space( substr( $str, 1, 1 ) );
2070             if ( !$first ) {
2071                 $xml .= "</datafield>\n";
2072                 if (   ( @$tags[$i] && @$tags[$i] > 10 )
2073                     && ( !$skip ) ) {
2074                     $xml .= "<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
2075                     $xml .= "<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
2076                     $first = 0;
2077                     $close_last_tag = 1;
2078                 } else {
2079                     $first = 1;
2080                 }
2081             } else {
2082                 if ( !$skip ) {
2083
2084                     # leader
2085                     if ( @$tags[$i] eq "000" ) {
2086                         $xml .= "<leader>@$values[$i]</leader>\n";
2087                         $first = 1;
2088
2089                         # rest of the fixed fields
2090                     } elsif ( @$tags[$i] < 10 ) {
2091                         $xml .= "<controlfield tag=\"@$tags[$i]\">@$values[$i]</controlfield>\n";
2092                         $first = 1;
2093                     } else {
2094                         $xml .= "<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
2095                         $xml .= "<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
2096                         $first = 0;
2097                         $close_last_tag = 1;
2098                     }
2099                 }
2100             }
2101         } else {    # @$tags[$i] eq $prevtag
2102             if ( !$skip ) {
2103                 if ($first) {
2104                     my $str = ( $indicator->[$j] // q{} ) . '  '; # extra space prevents substr outside of string warn
2105                     my $ind1 = _default_ind_to_space( substr( $str, 0, 1 ) );
2106                     my $ind2 = _default_ind_to_space( substr( $str, 1, 1 ) );
2107                     $xml .= "<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
2108                     $first = 0;
2109                     $close_last_tag = 1;
2110                 }
2111                 $xml .= "<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
2112             }
2113         }
2114         $prevtag = @$tags[$i];
2115     }
2116     $xml .= "</datafield>\n" if $close_last_tag;
2117     if ( C4::Context->preference('marcflavour') eq 'UNIMARC' and !$unimarc_and_100_exist ) {
2118
2119         #     warn "SETTING 100 for $auth_type";
2120         my $string = strftime( "%Y%m%d", localtime(time) );
2121
2122         # set 50 to position 26 is biblios, 13 if authorities
2123         my $pos = 26;
2124         $pos = 13 if $auth_type eq 'UNIMARCAUTH';
2125         $string = sprintf( "%-*s", 35, $string );
2126         substr( $string, $pos, 6, "50" );
2127         $xml .= "<datafield tag=\"100\" ind1=\"\" ind2=\"\">\n";
2128         $xml .= "<subfield code=\"a\">$string</subfield>\n";
2129         $xml .= "</datafield>\n";
2130     }
2131     $xml .= "</record>\n";
2132     $xml .= MARC::File::XML::footer();
2133     return $xml;
2134 }
2135
2136 =head2 _default_ind_to_space
2137
2138 Passed what should be an indicator returns a space
2139 if its undefined or zero length
2140
2141 =cut
2142
2143 sub _default_ind_to_space {
2144     my $s = shift;
2145     if ( !defined $s || $s eq q{} ) {
2146         return ' ';
2147     }
2148     return $s;
2149 }
2150
2151 =head2 TransformHtmlToMarc
2152
2153     L<$record> = TransformHtmlToMarc(L<$cgi>)
2154     L<$cgi> is the CGI object which contains the values for subfields
2155     {
2156         'tag_010_indicator1_531951' ,
2157         'tag_010_indicator2_531951' ,
2158         'tag_010_code_a_531951_145735' ,
2159         'tag_010_subfield_a_531951_145735' ,
2160         'tag_200_indicator1_873510' ,
2161         'tag_200_indicator2_873510' ,
2162         'tag_200_code_a_873510_673465' ,
2163         'tag_200_subfield_a_873510_673465' ,
2164         'tag_200_code_b_873510_704318' ,
2165         'tag_200_subfield_b_873510_704318' ,
2166         'tag_200_code_e_873510_280822' ,
2167         'tag_200_subfield_e_873510_280822' ,
2168         'tag_200_code_f_873510_110730' ,
2169         'tag_200_subfield_f_873510_110730' ,
2170     }
2171     L<$record> is the MARC::Record object.
2172
2173 =cut
2174
2175 sub TransformHtmlToMarc {
2176     my ($cgi, $isbiblio) = @_;
2177
2178     my @params = $cgi->multi_param();
2179
2180     # explicitly turn on the UTF-8 flag for all
2181     # 'tag_' parameters to avoid incorrect character
2182     # conversion later on
2183     my $cgi_params = $cgi->Vars;
2184     foreach my $param_name ( keys %$cgi_params ) {
2185         if ( $param_name =~ /^tag_/ ) {
2186             my $param_value = $cgi_params->{$param_name};
2187             unless ( Encode::is_utf8( $param_value ) ) {
2188                 $cgi_params->{$param_name} = Encode::decode('UTF-8', $param_value );
2189             }
2190         }
2191     }
2192
2193     # creating a new record
2194     my $record = MARC::Record->new();
2195     my @fields;
2196     my ($biblionumbertagfield, $biblionumbertagsubfield) = (-1, -1);
2197     ($biblionumbertagfield, $biblionumbertagsubfield) =
2198         &GetMarcFromKohaField( "biblio.biblionumber", '' ) if $isbiblio;
2199 #FIXME This code assumes that the CGI params will be in the same order as the fields in the template; this is no absolute guarantee!
2200     for (my $i = 0; $params[$i]; $i++ ) {    # browse all CGI params
2201         my $param    = $params[$i];
2202         my $newfield = 0;
2203
2204         # if we are on biblionumber, store it in the MARC::Record (it may not be in the edited fields)
2205         if ( $param eq 'biblionumber' ) {
2206             if ( $biblionumbertagfield < 10 ) {
2207                 $newfield = MARC::Field->new( $biblionumbertagfield, scalar $cgi->param($param), );
2208             } else {
2209                 $newfield = MARC::Field->new( $biblionumbertagfield, '', '', "$biblionumbertagsubfield" => scalar $cgi->param($param), );
2210             }
2211             push @fields, $newfield if ($newfield);
2212         } elsif ( $param =~ /^tag_(\d*)_indicator1_/ ) {    # new field start when having 'input name="..._indicator1_..."
2213             my $tag = $1;
2214
2215             my $ind1 = _default_ind_to_space( substr( $cgi->param($param), 0, 1 ) );
2216             my $ind2 = _default_ind_to_space( substr( $cgi->param( $params[ $i + 1 ] ), 0, 1 ) );
2217             $newfield = 0;
2218             my $j = $i + 2;
2219
2220             if ( $tag < 10 ) {                              # no code for theses fields
2221                                                             # in MARC editor, 000 contains the leader.
2222                 next if $tag == $biblionumbertagfield;
2223                 my $fval= $cgi->param($params[$j+1]);
2224                 if ( $tag eq '000' ) {
2225                     # Force a fake leader even if not provided to avoid crashing
2226                     # during decoding MARC record containing UTF-8 characters
2227                     $record->leader(
2228                         length( $fval ) == 24
2229                         ? $fval
2230                         : '     nam a22        4500'
2231                         )
2232                     ;
2233                     # between 001 and 009 (included)
2234                 } elsif ( $fval ne '' ) {
2235                     $fval     = StripNonXmlChars($fval);    #Strip out any non-XML characters like control characters
2236                     $newfield = MARC::Field->new( $tag, $fval, );
2237                 }
2238
2239                 # > 009, deal with subfields
2240             } else {
2241                 # browse subfields for this tag (reason for _code_ match)
2242                 while(defined $params[$j] && $params[$j] =~ /_code_/) {
2243                     last unless defined $params[$j+1];
2244                     $j += 2 and next
2245                         if $tag == $biblionumbertagfield and
2246                            $cgi->param($params[$j]) eq $biblionumbertagsubfield;
2247                     #if next param ne subfield, then it was probably empty
2248                     #try next param by incrementing j
2249                     if($params[$j+1]!~/_subfield_/) {$j++; next; }
2250                     my $fkey= $cgi->param($params[$j]);
2251                     my $fval= $cgi->param($params[$j+1]);
2252                     #check if subfield value not empty and field exists
2253                     if($fval ne '' && $newfield) {
2254                         $newfield->add_subfields( $fkey => $fval);
2255                     }
2256                     elsif($fval ne '') {
2257                         $fval     = StripNonXmlChars($fval);   #Strip out any non-XML characters like control characters
2258                         $newfield = MARC::Field->new( $tag, $ind1, $ind2, $fkey => $fval );
2259                     }
2260                     $j += 2;
2261                 } #end-of-while
2262                 $i= $j-1; #update i for outer loop accordingly
2263             }
2264             push @fields, $newfield if ($newfield);
2265         }
2266     }
2267
2268     @fields = sort { $a->tag() cmp $b->tag() } @fields;
2269     $record->append_fields(@fields);
2270     return $record;
2271 }
2272
2273 =head2 TransformMarcToKoha
2274
2275     $result = TransformMarcToKoha({ record => $record, limit_table => $limit })
2276
2277 Extract data from a MARC bib record into a hashref representing
2278 Koha biblio, biblioitems, and items fields.
2279
2280 If passed an undefined record will log the error and return an empty
2281 hash_ref.
2282
2283 =cut
2284
2285 sub TransformMarcToKoha {
2286     my ( $params ) = @_;
2287
2288     my $record = $params->{record};
2289     my $limit_table = $params->{limit_table} // q{};
2290     my $kohafields = $params->{kohafields};
2291
2292     my $result = {};
2293     if (!defined $record) {
2294         carp('TransformMarcToKoha called with undefined record');
2295         return $result;
2296     }
2297
2298     my %tables = ( biblio => 1, biblioitems => 1, items => 1 );
2299     if( $limit_table eq 'items' ) {
2300         %tables = ( items => 1 );
2301     } elsif ( $limit_table eq 'no_items' ){
2302         %tables = ( biblio => 1, biblioitems => 1 );
2303     }
2304
2305     # The next call acknowledges Default as the authoritative framework
2306     # for Koha to MARC mappings.
2307     my $mss = GetMarcSubfieldStructure( '', { unsafe => 1 } ); # Do not change framework
2308     @{$kohafields} = keys %{ $mss } unless $kohafields;
2309     foreach my $kohafield ( @{$kohafields} ) {
2310         my ( $table, $column ) = split /[.]/, $kohafield, 2;
2311         next unless $tables{$table};
2312         my ( $value, @values );
2313         foreach my $fldhash ( @{$mss->{$kohafield}} ) {
2314             my $tag = $fldhash->{tagfield};
2315             my $sub = $fldhash->{tagsubfield};
2316             foreach my $fld ( $record->field($tag) ) {
2317                 if( $sub eq '@' || $fld->is_control_field ) {
2318                     push @values, $fld->data if $fld->data;
2319                 } else {
2320                     push @values, grep { $_ } $fld->subfield($sub);
2321                 }
2322             }
2323         }
2324         if ( @values ){
2325             $value = join ' | ', uniq(@values);
2326
2327             # Additional polishing for individual kohafields
2328             if( $kohafield =~ /copyrightdate|publicationyear/ ) {
2329                 $value = _adjust_pubyear( $value );
2330             }
2331         }
2332
2333         next if !defined $value;
2334         my $key = _disambiguate( $table, $column );
2335         $result->{$key} = $value;
2336     }
2337     return $result;
2338 }
2339
2340 =head2 _disambiguate
2341
2342   $newkey = _disambiguate($table, $field);
2343
2344 This is a temporary hack to distinguish between the
2345 following sets of columns when using TransformMarcToKoha.
2346
2347   items.cn_source & biblioitems.cn_source
2348   items.cn_sort & biblioitems.cn_sort
2349
2350 Columns that are currently NOT distinguished (FIXME
2351 due to lack of time to fully test) are:
2352
2353   biblio.notes and biblioitems.notes
2354   biblionumber
2355   timestamp
2356   biblioitemnumber
2357
2358 FIXME - this is necessary because prefixing each column
2359 name with the table name would require changing lots
2360 of code and templates, and exposing more of the DB
2361 structure than is good to the UI templates, particularly
2362 since biblio and bibloitems may well merge in a future
2363 version.  In the future, it would also be good to
2364 separate DB access and UI presentation field names
2365 more.
2366
2367 =cut
2368
2369 sub _disambiguate {
2370     my ( $table, $column ) = @_;
2371     if ( $column eq "cn_sort" or $column eq "cn_source" ) {
2372         return $table . '.' . $column;
2373     } else {
2374         return $column;
2375     }
2376
2377 }
2378
2379 =head2 _adjust_pubyear
2380
2381     Helper routine for TransformMarcToKoha
2382
2383 =cut
2384
2385 sub _adjust_pubyear {
2386     my $retval = shift;
2387     # modify return value to keep only the 1st year found
2388     if( $retval =~ m/c(\d\d\d\d)/ and $1 > 0 ) { # search cYYYY first
2389         $retval = $1;
2390     } elsif( $retval =~ m/(\d\d\d\d)/ && $1 > 0 ) {
2391         $retval = $1;
2392     } elsif( $retval =~ m/(?<year>\d{1,3})[.Xx?-]/ ) {
2393         # See also bug 24674: enough to look at one unknown year char like .Xx-?
2394         # At this point in code 1234? or 1234- already passed the earlier regex
2395         # Things like 2-, 1xx, 1??? are now converted to a four positions-year.
2396         $retval = $+{year} * ( 10 ** (4-length($+{year})) );
2397     } else {
2398         $retval = undef;
2399     }
2400     return $retval;
2401 }
2402
2403 =head2 CountItemsIssued
2404
2405     my $count = CountItemsIssued( $biblionumber );
2406
2407 =cut
2408
2409 sub CountItemsIssued {
2410     my ($biblionumber) = @_;
2411     my $dbh            = C4::Context->dbh;
2412     my $sth            = $dbh->prepare('SELECT COUNT(*) as issuedCount FROM items, issues WHERE items.itemnumber = issues.itemnumber AND items.biblionumber = ?');
2413     $sth->execute($biblionumber);
2414     my $row = $sth->fetchrow_hashref();
2415     return $row->{'issuedCount'};
2416 }
2417
2418 =head2 ModZebra
2419
2420     ModZebra( $record_number, $op, $server );
2421
2422 $record_number is the authid or biblionumber we want to index
2423
2424 $op is the operation: specialUpdate or recordDelete
2425
2426 $server is authorityserver or biblioserver
2427
2428 =cut
2429
2430 sub ModZebra {
2431     my ( $record_number, $op, $server ) = @_;
2432     Koha::Logger->get->debug("ModZebra: updates requested for: $record_number $op $server");
2433     my $dbh = C4::Context->dbh;
2434
2435     # true ModZebra commented until indexdata fixes zebraDB crashes (it seems they occur on multiple updates
2436     # at the same time
2437     # replaced by a zebraqueue table, that is filled with ModZebra to run.
2438     # the table is emptied by rebuild_zebra.pl script (using the -z switch)
2439     my $check_sql = "SELECT COUNT(*) FROM zebraqueue
2440     WHERE server = ?
2441         AND   biblio_auth_number = ?
2442         AND   operation = ?
2443         AND   done = 0";
2444     my $check_sth = $dbh->prepare_cached($check_sql);
2445     $check_sth->execute( $server, $record_number, $op );
2446     my ($count) = $check_sth->fetchrow_array;
2447     $check_sth->finish();
2448     if ( $count == 0 ) {
2449         my $sth = $dbh->prepare("INSERT INTO zebraqueue  (biblio_auth_number,server,operation) VALUES(?,?,?)");
2450         $sth->execute( $record_number, $server, $op );
2451         $sth->finish;
2452     }
2453 }
2454
2455 =head1 INTERNAL FUNCTIONS
2456
2457 =head2 _koha_marc_update_bib_ids
2458
2459
2460   _koha_marc_update_bib_ids($record, $frameworkcode, $biblionumber, $biblioitemnumber);
2461
2462 Internal function to add or update biblionumber and biblioitemnumber to
2463 the MARC XML.
2464
2465 =cut
2466
2467 sub _koha_marc_update_bib_ids {
2468     my ( $record, $frameworkcode, $biblionumber, $biblioitemnumber ) = @_;
2469
2470     my ( $biblio_tag,     $biblio_subfield )     = GetMarcFromKohaField( "biblio.biblionumber" );
2471     die qq{No biblionumber tag for framework "$frameworkcode"} unless $biblio_tag;
2472     my ( $biblioitem_tag, $biblioitem_subfield ) = GetMarcFromKohaField( "biblioitems.biblioitemnumber" );
2473     die qq{No biblioitemnumber tag for framework "$frameworkcode"} unless $biblioitem_tag;
2474
2475     if ( $biblio_tag < 10 ) {
2476         C4::Biblio::UpsertMarcControlField( $record, $biblio_tag, $biblionumber );
2477     } else {
2478         C4::Biblio::UpsertMarcSubfield($record, $biblio_tag, $biblio_subfield, $biblionumber);
2479     }
2480     if ( $biblioitem_tag < 10 ) {
2481         C4::Biblio::UpsertMarcControlField( $record, $biblioitem_tag, $biblioitemnumber );
2482     } else {
2483         C4::Biblio::UpsertMarcSubfield($record, $biblioitem_tag, $biblioitem_subfield, $biblioitemnumber);
2484     }
2485
2486     # update the control number (001) in MARC
2487     if(C4::Context->preference('autoControlNumber') eq 'biblionumber'){
2488         unless($record->field('001')){
2489             $record->insert_fields_ordered(MARC::Field->new('001', $biblionumber));
2490         }
2491     }
2492 }
2493
2494 =head2 _koha_marc_update_biblioitem_cn_sort
2495
2496   _koha_marc_update_biblioitem_cn_sort($marc, $biblioitem, $frameworkcode);
2497
2498 Given a MARC bib record and the biblioitem hash, update the
2499 subfield that contains a copy of the value of biblioitems.cn_sort.
2500
2501 =cut
2502
2503 sub _koha_marc_update_biblioitem_cn_sort {
2504     my $marc          = shift;
2505     my $biblioitem    = shift;
2506     my $frameworkcode = shift;
2507
2508     my ( $biblioitem_tag, $biblioitem_subfield ) = GetMarcFromKohaField( "biblioitems.cn_sort" );
2509     return unless $biblioitem_tag;
2510
2511     my ($cn_sort) = GetClassSort( $biblioitem->{'biblioitems.cn_source'}, $biblioitem->{'cn_class'}, $biblioitem->{'cn_item'} );
2512
2513     if ( my $field = $marc->field($biblioitem_tag) ) {
2514         $field->delete_subfield( code => $biblioitem_subfield );
2515         if ( $cn_sort ne '' ) {
2516             $field->add_subfields( $biblioitem_subfield => $cn_sort );
2517         }
2518     } else {
2519
2520         # if we get here, no biblioitem tag is present in the MARC record, so
2521         # we'll create it if $cn_sort is not empty -- this would be
2522         # an odd combination of events, however
2523         if ($cn_sort) {
2524             $marc->insert_grouped_field( MARC::Field->new( $biblioitem_tag, ' ', ' ', $biblioitem_subfield => $cn_sort ) );
2525         }
2526     }
2527 }
2528
2529 =head2 _koha_modify_biblio
2530
2531   my ($biblionumber,$error) == _koha_modify_biblio($dbh,$biblio,$frameworkcode);
2532
2533 Internal function for updating the biblio table
2534
2535 =cut
2536
2537 sub _koha_modify_biblio {
2538     my ( $dbh, $biblio, $frameworkcode ) = @_;
2539     my $error;
2540
2541     my $query = "
2542         UPDATE biblio
2543         SET    frameworkcode = ?,
2544                author = ?,
2545                title = ?,
2546                subtitle = ?,
2547                medium = ?,
2548                part_number = ?,
2549                part_name = ?,
2550                unititle = ?,
2551                notes = ?,
2552                serial = ?,
2553                seriestitle = ?,
2554                copyrightdate = ?,
2555                abstract = ?
2556         WHERE  biblionumber = ?
2557         "
2558       ;
2559     my $sth = $dbh->prepare($query);
2560
2561     $sth->execute(
2562         $frameworkcode,        $biblio->{'author'},      $biblio->{'title'},       $biblio->{'subtitle'},
2563         $biblio->{'medium'},   $biblio->{'part_number'}, $biblio->{'part_name'},   $biblio->{'unititle'},
2564         $biblio->{'notes'},    $biblio->{'serial'},      $biblio->{'seriestitle'}, $biblio->{'copyrightdate'} ? int($biblio->{'copyrightdate'}) : undef,
2565         $biblio->{'abstract'}, $biblio->{'biblionumber'}
2566     ) if $biblio->{'biblionumber'};
2567
2568     my $cache = Koha::Cache::Memory::Lite->get_instance();
2569     $cache->clear_from_cache("FrameworkCode-" . $biblio->{biblionumber});
2570
2571     if ( $dbh->errstr || !$biblio->{'biblionumber'} ) {
2572         $error .= "ERROR in _koha_modify_biblio $query" . $dbh->errstr;
2573         warn $error;
2574     }
2575     return ( $biblio->{'biblionumber'}, $error );
2576 }
2577
2578 =head2 _koha_modify_biblioitem_nonmarc
2579
2580   my ($biblioitemnumber,$error) = _koha_modify_biblioitem_nonmarc( $dbh, $biblioitem );
2581
2582 =cut
2583
2584 sub _koha_modify_biblioitem_nonmarc {
2585     my ( $dbh, $biblioitem ) = @_;
2586     my $error;
2587
2588     # re-calculate the cn_sort, it may have changed
2589     my ($cn_sort) = GetClassSort( $biblioitem->{'biblioitems.cn_source'}, $biblioitem->{'cn_class'}, $biblioitem->{'cn_item'} );
2590
2591     my $query = "UPDATE biblioitems
2592     SET biblionumber    = ?,
2593         volume          = ?,
2594         number          = ?,
2595         itemtype        = ?,
2596         isbn            = ?,
2597         issn            = ?,
2598         publicationyear = ?,
2599         publishercode   = ?,
2600         volumedate      = ?,
2601         volumedesc      = ?,
2602         collectiontitle = ?,
2603         collectionissn  = ?,
2604         collectionvolume= ?,
2605         editionstatement= ?,
2606         editionresponsibility = ?,
2607         illus           = ?,
2608         pages           = ?,
2609         notes           = ?,
2610         size            = ?,
2611         place           = ?,
2612         lccn            = ?,
2613         url             = ?,
2614         cn_source       = ?,
2615         cn_class        = ?,
2616         cn_item         = ?,
2617         cn_suffix       = ?,
2618         cn_sort         = ?,
2619         totalissues     = ?,
2620         ean             = ?,
2621         agerestriction  = ?
2622         where biblioitemnumber = ?
2623         ";
2624     my $sth = $dbh->prepare($query);
2625     $sth->execute(
2626         $biblioitem->{'biblionumber'},     $biblioitem->{'volume'},           $biblioitem->{'number'},                $biblioitem->{'itemtype'},
2627         $biblioitem->{'isbn'},             $biblioitem->{'issn'},             $biblioitem->{'publicationyear'},       $biblioitem->{'publishercode'},
2628         $biblioitem->{'volumedate'},       $biblioitem->{'volumedesc'},       $biblioitem->{'collectiontitle'},       $biblioitem->{'collectionissn'},
2629         $biblioitem->{'collectionvolume'}, $biblioitem->{'editionstatement'}, $biblioitem->{'editionresponsibility'}, $biblioitem->{'illus'},
2630         $biblioitem->{'pages'},            $biblioitem->{'bnotes'},           $biblioitem->{'size'},                  $biblioitem->{'place'},
2631         $biblioitem->{'lccn'},             $biblioitem->{'url'},              $biblioitem->{'biblioitems.cn_source'}, $biblioitem->{'cn_class'},
2632         $biblioitem->{'cn_item'},          $biblioitem->{'cn_suffix'},        $cn_sort,                               $biblioitem->{'totalissues'},
2633         $biblioitem->{'ean'},              $biblioitem->{'agerestriction'},   $biblioitem->{'biblioitemnumber'}
2634     );
2635     if ( $dbh->errstr ) {
2636         $error .= "ERROR in _koha_modify_biblioitem_nonmarc $query" . $dbh->errstr;
2637         warn $error;
2638     }
2639     return ( $biblioitem->{'biblioitemnumber'}, $error );
2640 }
2641
2642 =head2 _koha_delete_biblio
2643
2644   $error = _koha_delete_biblio($dbh,$biblionumber);
2645
2646 Internal sub for deleting from biblio table -- also saves to deletedbiblio
2647
2648 C<$dbh> - the database handle
2649
2650 C<$biblionumber> - the biblionumber of the biblio to be deleted
2651
2652 =cut
2653
2654 # FIXME: add error handling
2655
2656 sub _koha_delete_biblio {
2657     my ( $dbh, $biblionumber ) = @_;
2658
2659     # get all the data for this biblio
2660     my $sth = $dbh->prepare("SELECT * FROM biblio WHERE biblionumber=?");
2661     $sth->execute($biblionumber);
2662
2663     # FIXME There is a transaction in _koha_delete_biblio_metadata
2664     # But actually all the following should be done inside a single transaction
2665     if ( my $data = $sth->fetchrow_hashref ) {
2666
2667         # save the record in deletedbiblio
2668         # find the fields to save
2669         my $query = "INSERT INTO deletedbiblio SET ";
2670         my @bind  = ();
2671         foreach my $temp ( keys %$data ) {
2672             $query .= "$temp = ?,";
2673             push( @bind, $data->{$temp} );
2674         }
2675
2676         # replace the last , by ",?)"
2677         $query =~ s/\,$//;
2678         my $bkup_sth = $dbh->prepare($query);
2679         $bkup_sth->execute(@bind);
2680         $bkup_sth->finish;
2681
2682         _koha_delete_biblio_metadata( $biblionumber );
2683
2684         # delete the biblio
2685         my $sth2 = $dbh->prepare("DELETE FROM biblio WHERE biblionumber=?");
2686         $sth2->execute($biblionumber);
2687         # update the timestamp (Bugzilla 7146)
2688         $sth2= $dbh->prepare("UPDATE deletedbiblio SET timestamp=NOW() WHERE biblionumber=?");
2689         $sth2->execute($biblionumber);
2690         $sth2->finish;
2691     }
2692     $sth->finish;
2693     return;
2694 }
2695
2696 =head2 _koha_delete_biblioitems
2697
2698   $error = _koha_delete_biblioitems($dbh,$biblioitemnumber);
2699
2700 Internal sub for deleting from biblioitems table -- also saves to deletedbiblioitems
2701
2702 C<$dbh> - the database handle
2703 C<$biblionumber> - the biblioitemnumber of the biblioitem to be deleted
2704
2705 =cut
2706
2707 # FIXME: add error handling
2708
2709 sub _koha_delete_biblioitems {
2710     my ( $dbh, $biblioitemnumber ) = @_;
2711
2712     # get all the data for this biblioitem
2713     my $sth = $dbh->prepare("SELECT * FROM biblioitems WHERE biblioitemnumber=?");
2714     $sth->execute($biblioitemnumber);
2715
2716     if ( my $data = $sth->fetchrow_hashref ) {
2717
2718         # save the record in deletedbiblioitems
2719         # find the fields to save
2720         my $query = "INSERT INTO deletedbiblioitems SET ";
2721         my @bind  = ();
2722         foreach my $temp ( keys %$data ) {
2723             $query .= "$temp = ?,";
2724             push( @bind, $data->{$temp} );
2725         }
2726
2727         # replace the last , by ",?)"
2728         $query =~ s/\,$//;
2729         my $bkup_sth = $dbh->prepare($query);
2730         $bkup_sth->execute(@bind);
2731         $bkup_sth->finish;
2732
2733         # delete the biblioitem
2734         my $sth2 = $dbh->prepare("DELETE FROM biblioitems WHERE biblioitemnumber=?");
2735         $sth2->execute($biblioitemnumber);
2736         # update the timestamp (Bugzilla 7146)
2737         $sth2= $dbh->prepare("UPDATE deletedbiblioitems SET timestamp=NOW() WHERE biblioitemnumber=?");
2738         $sth2->execute($biblioitemnumber);
2739         $sth2->finish;
2740     }
2741     $sth->finish;
2742     return;
2743 }
2744
2745 =head2 _koha_delete_biblio_metadata
2746
2747   $error = _koha_delete_biblio_metadata($biblionumber);
2748
2749 C<$biblionumber> - the biblionumber of the biblio metadata to be deleted
2750
2751 =cut
2752
2753 sub _koha_delete_biblio_metadata {
2754     my ($biblionumber) = @_;
2755
2756     my $dbh    = C4::Context->dbh;
2757     my $schema = Koha::Database->new->schema;
2758     $schema->txn_do(
2759         sub {
2760             $dbh->do( q|
2761                 INSERT INTO deletedbiblio_metadata (biblionumber, format, `schema`, metadata)
2762                 SELECT biblionumber, format, `schema`, metadata FROM biblio_metadata WHERE biblionumber=?
2763             |,  undef, $biblionumber );
2764             $dbh->do( q|DELETE FROM biblio_metadata WHERE biblionumber=?|,
2765                 undef, $biblionumber );
2766         }
2767     );
2768 }
2769
2770 =head1 UNEXPORTED FUNCTIONS
2771
2772 =head2 ModBiblioMarc
2773
2774   ModBiblioMarc($newrec,$biblionumber);
2775
2776 Add MARC XML data for a biblio to koha
2777
2778 Function exported, but should NOT be used, unless you really know what you're doing
2779
2780 =cut
2781
2782 sub ModBiblioMarc {
2783     # pass the MARC::Record to this function, and it will create the records in
2784     # the marcxml field
2785     my ( $record, $biblionumber, $params ) = @_;
2786     if ( !$record ) {
2787         carp 'ModBiblioMarc passed an undefined record';
2788         return;
2789     }
2790
2791     my $skip_record_index = $params->{skip_record_index} || 0;
2792
2793     # Clone record as it gets modified
2794     $record = $record->clone();
2795     my $dbh    = C4::Context->dbh;
2796     my @fields = $record->fields();
2797     my $encoding = C4::Context->preference("marcflavour");
2798
2799     # deal with UNIMARC field 100 (encoding) : create it if needed & set encoding to unicode
2800     if ( $encoding eq "UNIMARC" ) {
2801         my $defaultlanguage = C4::Context->preference("UNIMARCField100Language");
2802         $defaultlanguage = "fre" if (!$defaultlanguage || length($defaultlanguage) != 3);
2803         my $string = $record->subfield( 100, "a" );
2804         if ( ($string) && ( length( $record->subfield( 100, "a" ) ) == 36 ) ) {
2805             my $f100 = $record->field(100);
2806             $record->delete_field($f100);
2807         } else {
2808             $string = POSIX::strftime( "%Y%m%d", localtime );
2809             $string =~ s/\-//g;
2810             $string = sprintf( "%-*s", 35, $string );
2811             substr ( $string, 22, 3, $defaultlanguage);
2812         }
2813         substr( $string, 25, 3, "y50" );
2814         unless ( $record->subfield( 100, "a" ) ) {
2815             $record->insert_fields_ordered( MARC::Field->new( 100, "", "", "a" => $string ) );
2816         }
2817     }
2818
2819     #enhancement 5374: update transaction date (005) for marc21/unimarc
2820     if($encoding =~ /MARC21|UNIMARC/) {
2821       my @a= (localtime) [5,4,3,2,1,0]; $a[0]+=1900; $a[1]++;
2822         # YY MM DD HH MM SS (update year and month)
2823       my $f005= $record->field('005');
2824       $f005->update(sprintf("%4d%02d%02d%02d%02d%04.1f",@a)) if $f005;
2825     }
2826
2827     my $metadata = {
2828         biblionumber => $biblionumber,
2829         format       => 'marcxml',
2830         schema       => C4::Context->preference('marcflavour'),
2831     };
2832     $record->as_usmarc; # Bug 20126/10455 This triggers field length calculation
2833
2834     my $m_rs = Koha::Biblio::Metadatas->find($metadata) //
2835         Koha::Biblio::Metadata->new($metadata);
2836
2837     my $userenv = C4::Context->userenv;
2838     if ($userenv) {
2839         my $borrowernumber = $userenv->{number};
2840         my $borrowername = join ' ', map { $_ // q{} } @$userenv{qw(firstname surname)};
2841         unless ($m_rs->in_storage) {
2842             Koha::Util::MARC::set_marc_field($record, C4::Context->preference('MarcFieldForCreatorId'), $borrowernumber);
2843             Koha::Util::MARC::set_marc_field($record, C4::Context->preference('MarcFieldForCreatorName'), $borrowername);
2844         }
2845         Koha::Util::MARC::set_marc_field($record, C4::Context->preference('MarcFieldForModifierId'), $borrowernumber);
2846         Koha::Util::MARC::set_marc_field($record, C4::Context->preference('MarcFieldForModifierName'), $borrowername);
2847     }
2848
2849     $m_rs->metadata( $record->as_xml_record($encoding) );
2850     $m_rs->store;
2851
2852     unless ( $skip_record_index ) {
2853         my $indexer = Koha::SearchEngine::Indexer->new({ index => $Koha::SearchEngine::BIBLIOS_INDEX });
2854         $indexer->index_records( $biblionumber, "specialUpdate", "biblioserver" );
2855     }
2856
2857     return $biblionumber;
2858 }
2859
2860 =head2 prepare_host_field
2861
2862 $marcfield = prepare_host_field( $hostbiblioitem, $marcflavour );
2863 Generate the host item entry for an analytic child entry
2864
2865 =cut
2866
2867 sub prepare_host_field {
2868     my ( $hostbiblio, $marcflavour ) = @_;
2869     $marcflavour ||= C4::Context->preference('marcflavour');
2870
2871     my $biblio = Koha::Biblios->find($hostbiblio);
2872     my $host = $biblio->metadata->record;
2873     # unfortunately as_string does not 'do the right thing'
2874     # if field returns undef
2875     my %sfd;
2876     my $field;
2877     my $host_field;
2878     if ( $marcflavour eq 'MARC21' ) {
2879         if ( $field = $host->field('100') || $host->field('110') || $host->field('11') ) {
2880             my $s = $field->as_string('ab');
2881             if ($s) {
2882                 $sfd{a} = $s;
2883             }
2884         }
2885         if ( $field = $host->field('245') ) {
2886             my $s = $field->as_string('a');
2887             if ($s) {
2888                 $sfd{t} = $s;
2889             }
2890         }
2891         if ( $field = $host->field('260') ) {
2892             my $s = $field->as_string('abc');
2893             if ($s) {
2894                 $sfd{d} = $s;
2895             }
2896         }
2897         if ( $field = $host->field('240') ) {
2898             my $s = $field->as_string();
2899             if ($s) {
2900                 $sfd{b} = $s;
2901             }
2902         }
2903         if ( $field = $host->field('022') ) {
2904             my $s = $field->as_string('a');
2905             if ($s) {
2906                 $sfd{x} = $s;
2907             }
2908         }
2909         if ( $field = $host->field('020') ) {
2910             my $s = $field->as_string('a');
2911             if ($s) {
2912                 $sfd{z} = $s;
2913             }
2914         }
2915         if ( $field = $host->field('001') ) {
2916             $sfd{w} = $field->data(),;
2917         }
2918         $host_field = MARC::Field->new( 773, '0', ' ', %sfd );
2919         return $host_field;
2920     }
2921     elsif ( $marcflavour eq 'UNIMARC' ) {
2922         #author
2923         if ( $field = $host->field('700') || $host->field('710') || $host->field('720') ) {
2924             my $s = $field->as_string('ab');
2925             if ($s) {
2926                 $sfd{a} = $s;
2927             }
2928         }
2929         #title
2930         if ( $field = $host->field('200') ) {
2931             my $s = $field->as_string('a');
2932             if ($s) {
2933                 $sfd{t} = $s;
2934             }
2935         }
2936         #place of publicaton
2937         if ( $field = $host->field('210') ) {
2938             my $s = $field->as_string('a');
2939             if ($s) {
2940                 $sfd{c} = $s;
2941             }
2942         }
2943         #date of publication
2944         if ( $field = $host->field('210') ) {
2945             my $s = $field->as_string('d');
2946             if ($s) {
2947                 $sfd{d} = $s;
2948             }
2949         }
2950         #edition statement
2951         if ( $field = $host->field('205') ) {
2952             my $s = $field->as_string();
2953             if ($s) {
2954                 $sfd{e} = $s;
2955             }
2956         }
2957         #URL
2958         if ( $field = $host->field('856') ) {
2959             my $s = $field->as_string('u');
2960             if ($s) {
2961                 $sfd{u} = $s;
2962             }
2963         }
2964         #ISSN
2965         if ( $field = $host->field('011') ) {
2966             my $s = $field->as_string('a');
2967             if ($s) {
2968                 $sfd{x} = $s;
2969             }
2970         }
2971         #ISBN
2972         if ( $field = $host->field('010') ) {
2973             my $s = $field->as_string('a');
2974             if ($s) {
2975                 $sfd{y} = $s;
2976             }
2977         }
2978         if ( $field = $host->field('001') ) {
2979             $sfd{0} = $field->data(),;
2980         }
2981         $host_field = MARC::Field->new( 461, '0', ' ', %sfd );
2982         return $host_field;
2983     }
2984     return;
2985 }
2986
2987
2988 =head2 UpdateTotalIssues
2989
2990   UpdateTotalIssues($biblionumber, $increase, [$value])
2991
2992 Update the total issue count for a particular bib record.
2993
2994 =over 4
2995
2996 =item C<$biblionumber> is the biblionumber of the bib to update
2997
2998 =item C<$increase> is the amount to increase (or decrease) the total issues count by
2999
3000 =item C<$value> is the absolute value that total issues count should be set to. If provided, C<$increase> is ignored.
3001
3002 =back
3003
3004 =cut
3005
3006 sub UpdateTotalIssues {
3007     my ($biblionumber, $increase, $value, $skip_holds_queue) = @_;
3008     my $totalissues;
3009
3010     my $biblio = Koha::Biblios->find($biblionumber);
3011     unless ($biblio) {
3012         carp "UpdateTotalIssues could not get biblio";
3013         return;
3014     }
3015
3016     my $record = $biblio->metadata->record;
3017     unless ($record) {
3018         carp "UpdateTotalIssues could not get biblio record";
3019         return;
3020     }
3021     my $biblioitem = $biblio->biblioitem;
3022     my ($totalissuestag, $totalissuessubfield) = GetMarcFromKohaField( 'biblioitems.totalissues' );
3023     unless ($totalissuestag) {
3024         return 1; # There is nothing to do
3025     }
3026
3027     if (defined $value) {
3028         $totalissues = $value;
3029     } else {
3030         $totalissues = $biblioitem->totalissues + $increase;
3031     }
3032
3033      my $field = $record->field($totalissuestag);
3034      if (defined $field) {
3035          $field->update( $totalissuessubfield => $totalissues );
3036      } else {
3037          $field = MARC::Field->new($totalissuestag, '0', '0',
3038                  $totalissuessubfield => $totalissues);
3039          $record->insert_grouped_field($field);
3040      }
3041
3042      return ModBiblio($record, $biblionumber, $biblio->frameworkcode, { skip_holds_queue => $skip_holds_queue });
3043 }
3044
3045 =head2 RemoveAllNsb
3046
3047     &RemoveAllNsb($record);
3048
3049 Removes all nsb/nse chars from a record
3050
3051 =cut
3052
3053 sub RemoveAllNsb {
3054     my $record = shift;
3055     if (!$record) {
3056         carp 'RemoveAllNsb called with undefined record';
3057         return;
3058     }
3059
3060     SetUTF8Flag($record);
3061
3062     foreach my $field ($record->fields()) {
3063         if ($field->is_control_field()) {
3064             $field->update(nsb_clean($field->data()));
3065         } else {
3066             my @subfields = $field->subfields();
3067             my @new_subfields;
3068             foreach my $subfield (@subfields) {
3069                 push @new_subfields, $subfield->[0] => nsb_clean($subfield->[1]);
3070             }
3071             if (scalar(@new_subfields) > 0) {
3072                 my $new_field;
3073                 eval {
3074                     $new_field = MARC::Field->new(
3075                         $field->tag(),
3076                         $field->indicator(1),
3077                         $field->indicator(2),
3078                         @new_subfields
3079                     );
3080                 };
3081                 if ($@) {
3082                     warn "error in RemoveAllNsb : $@";
3083                 } else {
3084                     $field->replace_with($new_field);
3085                 }
3086             }
3087         }
3088     }
3089
3090     return $record;
3091 }
3092
3093 =head2 ApplyMarcOverlayRules
3094
3095     my $record = ApplyMarcOverlayRules($params)
3096
3097 Applies marc merge rules to a record.
3098
3099 C<$params> is expected to be a hashref with below keys defined.
3100
3101 =over 4
3102
3103 =item C<biblionumber>
3104 biblionumber of old record
3105
3106 =item C<record>
3107 Incoming record that will be merged with old record
3108
3109 =item C<overlay_context>
3110 hashref containing at least one context module and filter value on
3111 the form {module => filter, ...}.
3112
3113 =back
3114
3115 Returns:
3116
3117 =over 4
3118
3119 =item C<$record>
3120
3121 Merged MARC record based with merge rules for C<context> applied. If no old
3122 record for C<biblionumber> can be found, C<record> is returned unchanged.
3123 Default action when no matching context is found to return C<record> unchanged.
3124 If no rules are found for a certain field tag the default is to overwrite with
3125 fields with this field tag from C<record>.
3126
3127 =back
3128
3129 =cut
3130
3131 sub ApplyMarcOverlayRules {
3132     my ($params) = @_;
3133     my $biblionumber = $params->{biblionumber};
3134     my $incoming_record = $params->{record};
3135
3136     if (!$biblionumber) {
3137         carp 'ApplyMarcOverlayRules called on undefined biblionumber';
3138         return;
3139     }
3140     if (!$incoming_record) {
3141         carp 'ApplyMarcOverlayRules called on undefined record';
3142         return;
3143     }
3144     my $biblio = Koha::Biblios->find($biblionumber);
3145     my $old_record = $biblio->metadata->record;
3146
3147     # Skip overlay rules if called with no context
3148     if ($old_record && defined $params->{overlay_context}) {
3149         return Koha::MarcOverlayRules->merge_records($old_record, $incoming_record, $params->{overlay_context});
3150     }
3151     return $incoming_record;
3152 }
3153
3154 =head2 _after_biblio_action_hooks
3155
3156 Helper method that takes care of calling all plugin hooks
3157
3158 =cut
3159
3160 sub _after_biblio_action_hooks {
3161     my ( $args ) = @_;
3162
3163     my $biblio_id = $args->{biblio_id};
3164     my $action    = $args->{action} // q{};
3165
3166     my $biblio = $action ne 'delete' ? Koha::Biblios->find($biblio_id) : undef;
3167     Koha::Plugins->call(
3168         'after_biblio_action',
3169         {
3170             action    => $action,
3171             biblio    => $biblio,
3172             biblio_id => $biblio_id,
3173         }
3174     );
3175 }
3176
3177 1;
3178
3179 __END__
3180
3181 =head1 AUTHOR
3182
3183 Koha Development Team <http://koha-community.org/>
3184
3185 Paul POULAIN paul.poulain@free.fr
3186
3187 Joshua Ferraro jmf@liblime.com
3188
3189 =cut