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