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