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