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) 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,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, $ind1_defaultvalue, $ind2_defaultvalue );
 872
 873     while ( ( $tag, $liblibrarian, $libopac, $mandatory, $repeatable, $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}->{repeatable} = $repeatable;
 878     $res->{$tag}->{ind1_defaultvalue} = $ind1_defaultvalue;
 879     $res->{$tag}->{ind2_defaultvalue} = $ind2_defaultvalue;
 880     }
 881
 882     $sth = $dbh->prepare(
 883         "SELECT tagfield,tagsubfield,liblibrarian,libopac,tab,mandatory,repeatable,authorised_value,authtypecode,value_builder,kohafield,seealso,hidden,isurl,link,defaultvalue,maxlength
 884          FROM   marc_subfield_structure
 885          WHERE  frameworkcode=?
 886          ORDER BY tagfield,tagsubfield
 887         "
 888     );
 889
 890     $sth->execute($frameworkcode);
 891
 892     my $subfield;
 893     my $authorised_value;
 894     my $authtypecode;
 895     my $value_builder;
 896     my $kohafield;
 897     my $seealso;
 898     my $hidden;
 899     my $isurl;
 900     my $link;
 901     my $defaultvalue;
 902     my $maxlength;
 903
 904     while (
 905         (   $tag,          $subfield,      $liblibrarian, $libopac, $tab,    $mandatory, $repeatable, $authorised_value,
 906             $authtypecode, $value_builder, $kohafield,    $seealso, $hidden, $isurl,     $link,       $defaultvalue,
 907             $maxlength
 908         )
 909         = $sth->fetchrow
 910       ) {
 911         $res->{$tag}->{$subfield}->{lib}              = ( $forlibrarian or !$libopac ) ? $liblibrarian : $libopac;
 912         $res->{$tag}->{$subfield}->{tab}              = $tab;
 913         $res->{$tag}->{$subfield}->{mandatory}        = $mandatory;
 914         $res->{$tag}->{$subfield}->{repeatable}       = $repeatable;
 915         $res->{$tag}->{$subfield}->{authorised_value} = $authorised_value;
 916         $res->{$tag}->{$subfield}->{authtypecode}     = $authtypecode;
 917         $res->{$tag}->{$subfield}->{value_builder}    = $value_builder;
 918         $res->{$tag}->{$subfield}->{kohafield}        = $kohafield;
 919         $res->{$tag}->{$subfield}->{seealso}          = $seealso;
 920         $res->{$tag}->{$subfield}->{hidden}           = $hidden;
 921         $res->{$tag}->{$subfield}->{isurl}            = $isurl;
 922         $res->{$tag}->{$subfield}->{'link'}           = $link;
 923         $res->{$tag}->{$subfield}->{defaultvalue}     = $defaultvalue;
 924         $res->{$tag}->{$subfield}->{maxlength}        = $maxlength;
 925     }
 926
 927     $cache->set_in_cache($cache_key, $res);
 928     return $res;
 929 }
 930
 931 =head2 GetUsedMarcStructure
 932
 933 The same function as GetMarcStructure except it just takes field
 934 in tab 0-9. (used field)
 935
 936   my $results = GetUsedMarcStructure($frameworkcode);
 937
 938 C<$results> is a ref to an array which each case contains a ref
 939 to a hash which each keys is the columns from marc_subfield_structure
 940
 941 C<$frameworkcode> is the framework code.
 942
 943 =cut
 944
 945 sub GetUsedMarcStructure {
 946     my $frameworkcode = shift || '';
 947     my $query = q{
 948         SELECT *
 949         FROM   marc_subfield_structure
 950         WHERE   tab > -1
 951             AND frameworkcode = ?
 952         ORDER BY tagfield, tagsubfield
 953     };
 954     my $sth = C4::Context->dbh->prepare($query);
 955     $sth->execute($frameworkcode);
 956     return $sth->fetchall_arrayref( {} );
 957 }
 958
 959 =pod
 960
 961 =head2 GetMarcSubfieldStructure
 962
 963   my $structure = GetMarcSubfieldStructure($frameworkcode, [$params]);
 964
 965 Returns a reference to hash representing MARC subfield structure
 966 for framework with framework code C<$frameworkcode>, C<$params> is
 967 optional and may contain additional options.
 968
 969 =over 4
 970
 971 =item C<$frameworkcode>
 972
 973 The framework code.
 974
 975 =item C<$params>
 976
 977 An optional hash reference with additional options.
 978 The following options are supported:
 979
 980 =over 4
 981
 982 =item unsafe
 983
 984 Pass { unsafe => 1 } do disable cached object cloning,
 985 and instead get a shared reference, resulting in better
 986 performance (but care must be taken so that retured object
 987 is never modified).
 988
 989 Note: If you call GetMarcSubfieldStructure with unsafe => 1, do not modify or
 990 even autovivify its contents. It is a cached/shared data structure. Your
 991 changes would be passed around in subsequent calls.
 992
 993 =back
 994
 995 =back
 996
 997 =cut
 998
 999 sub GetMarcSubfieldStructure {
1000     my ( $frameworkcode, $params ) = @_;
1001
1002     $frameworkcode //= '';
1003
1004     my $cache     = Koha::Caches->get_instance();
1005     my $cache_key = "MarcSubfieldStructure-$frameworkcode";
1006     my $cached  = $cache->get_from_cache($cache_key, { unsafe => ($params && $params->{unsafe}) });
1007     return $cached if $cached;
1008
1009     my $dbh = C4::Context->dbh;
1010     # We moved to selectall_arrayref since selectall_hashref does not
1011     # keep duplicate mappings on kohafield (like place in 260 vs 264)
1012     my $subfield_aref = $dbh->selectall_arrayref( q|
1013         SELECT *
1014         FROM marc_subfield_structure
1015         WHERE frameworkcode = ?
1016         AND kohafield > ''
1017         ORDER BY frameworkcode,tagfield,tagsubfield
1018     |, { Slice => {} }, $frameworkcode );
1019     # Now map the output to a hash structure
1020     my $subfield_structure = {};
1021     foreach my $row ( @$subfield_aref ) {
1022         push @{ $subfield_structure->{ $row->{kohafield} }}, $row;
1023     }
1024     $cache->set_in_cache( $cache_key, $subfield_structure );
1025     return $subfield_structure;
1026 }
1027
1028 =head2 GetMarcFromKohaField
1029
1030     ( $field,$subfield ) = GetMarcFromKohaField( $kohafield );
1031     @fields = GetMarcFromKohaField( $kohafield );
1032     $field = GetMarcFromKohaField( $kohafield );
1033
1034     Returns the MARC fields & subfields mapped to $kohafield.
1035     Since the Default framework is considered as authoritative for such
1036     mappings, the former frameworkcode parameter is obsoleted.
1037
1038     In list context all mappings are returned; there can be multiple
1039     mappings. Note that in the above example you could miss a second
1040     mappings in the first call.
1041     In scalar context only the field tag of the first mapping is returned.
1042
1043 =cut
1044
1045 sub GetMarcFromKohaField {
1046     my ( $kohafield ) = @_;
1047     return unless $kohafield;
1048     # The next call uses the Default framework since it is AUTHORITATIVE
1049     # for all Koha to MARC mappings.
1050     my $mss = GetMarcSubfieldStructure( '', { unsafe => 1 } ); # Do not change framework
1051     my @retval;
1052     foreach( @{ $mss->{$kohafield} } ) {
1053         push @retval, $_->{tagfield}, $_->{tagsubfield};
1054     }
1055     return wantarray ? @retval : ( @retval ? $retval[0] : undef );
1056 }
1057
1058 =head2 GetMarcSubfieldStructureFromKohaField
1059
1060     my $str = GetMarcSubfieldStructureFromKohaField( $kohafield );
1061
1062     Returns marc subfield structure information for $kohafield.
1063     The Default framework is used, since it is authoritative for kohafield
1064     mappings.
1065     In list context returns a list of all hashrefs, since there may be
1066     multiple mappings. In scalar context the first hashref is returned.
1067
1068 =cut
1069
1070 sub GetMarcSubfieldStructureFromKohaField {
1071     my ( $kohafield ) = @_;
1072
1073     return unless $kohafield;
1074
1075     # The next call uses the Default framework since it is AUTHORITATIVE
1076     # for all Koha to MARC mappings.
1077     my $mss = GetMarcSubfieldStructure( '', { unsafe => 1 } ); # Do not change framework
1078     return unless $mss->{$kohafield};
1079     return wantarray ? @{$mss->{$kohafield}} : $mss->{$kohafield}->[0];
1080 }
1081
1082 =head2 GetMarcBiblio
1083
1084   my $record = GetMarcBiblio({
1085       biblionumber => $biblionumber,
1086       embed_items  => $embeditems,
1087       opac         => $opac,
1088       borcat       => $patron_category });
1089
1090 Returns MARC::Record representing a biblio record, or C<undef> if the
1091 biblionumber doesn't exist.
1092
1093 Both embed_items and opac are optional.
1094 If embed_items is passed and is 1, items are embedded.
1095 If opac is passed and is 1, the record is filtered as needed.
1096
1097 =over 4
1098
1099 =item C<$biblionumber>
1100
1101 the biblionumber
1102
1103 =item C<$embeditems>
1104
1105 set to true to include item information.
1106
1107 =item C<$opac>
1108
1109 set to true to make the result suited for OPAC view. This causes things like
1110 OpacHiddenItems to be applied.
1111
1112 =item C<$borcat>
1113
1114 If the OpacHiddenItemsExceptions system preference is set, this patron category
1115 can be used to make visible OPAC items which would be normally hidden.
1116 It only makes sense in combination both embed_items and opac values true.
1117
1118 =back
1119
1120 =cut
1121
1122 sub GetMarcBiblio {
1123     my ($params) = @_;
1124
1125     if (not defined $params) {
1126         carp 'GetMarcBiblio called without parameters';
1127         return;
1128     }
1129
1130     my $biblionumber = $params->{biblionumber};
1131     my $embeditems   = $params->{embed_items} || 0;
1132     my $opac         = $params->{opac} || 0;
1133     my $borcat       = $params->{borcat} // q{};
1134
1135     if (not defined $biblionumber) {
1136         carp 'GetMarcBiblio called with undefined biblionumber';
1137         return;
1138     }
1139
1140     my $dbh          = C4::Context->dbh;
1141     my $sth          = $dbh->prepare("SELECT biblioitemnumber FROM biblioitems WHERE biblionumber=? ");
1142     $sth->execute($biblionumber);
1143     my $row     = $sth->fetchrow_hashref;
1144     my $biblioitemnumber = $row->{'biblioitemnumber'};
1145     my $marcxml = GetXmlBiblio( $biblionumber );
1146     $marcxml = StripNonXmlChars( $marcxml );
1147     my $frameworkcode = GetFrameworkCode($biblionumber);
1148     MARC::File::XML->default_record_format( C4::Context->preference('marcflavour') );
1149     my $record = MARC::Record->new();
1150
1151     if ($marcxml) {
1152         $record = eval {
1153             MARC::Record::new_from_xml( $marcxml, "utf8",
1154                 C4::Context->preference('marcflavour') );
1155         };
1156         if ($@) { warn " problem with :$biblionumber : $@ \n$marcxml"; }
1157         return unless $record;
1158
1159         C4::Biblio::_koha_marc_update_bib_ids( $record, $frameworkcode, $biblionumber,
1160             $biblioitemnumber );
1161         C4::Biblio::EmbedItemsInMarcBiblio({
1162             marc_record  => $record,
1163             biblionumber => $biblionumber,
1164             opac         => $opac,
1165             borcat       => $borcat })
1166           if ($embeditems);
1167
1168         return $record;
1169     }
1170     else {
1171         return;
1172     }
1173 }
1174
1175 =head2 GetXmlBiblio
1176
1177   my $marcxml = GetXmlBiblio($biblionumber);
1178
1179 Returns biblio_metadata.metadata/marcxml of the biblionumber passed in parameter.
1180 The XML should only contain biblio information (item information is no longer stored in marcxml field)
1181
1182 =cut
1183
1184 sub GetXmlBiblio {
1185     my ($biblionumber) = @_;
1186     my $dbh = C4::Context->dbh;
1187     return unless $biblionumber;
1188     my ($marcxml) = $dbh->selectrow_array(
1189         q|
1190         SELECT metadata
1191         FROM biblio_metadata
1192         WHERE biblionumber=?
1193             AND format='marcxml'
1194             AND `schema`=?
1195     |, undef, $biblionumber, C4::Context->preference('marcflavour')
1196     );
1197     return $marcxml;
1198 }
1199
1200 =head2 GetMarcPrice
1201
1202 return the prices in accordance with the Marc format.
1203
1204 returns 0 if no price found
1205 returns undef if called without a marc record or with
1206 an unrecognized marc format
1207
1208 =cut
1209
1210 sub GetMarcPrice {
1211     my ( $record, $marcflavour ) = @_;
1212     if (!$record) {
1213         carp 'GetMarcPrice called on undefined record';
1214         return;
1215     }
1216
1217     my @listtags;
1218     my $subfield;
1219
1220     if ( $marcflavour eq "MARC21" || $marcflavour eq "NORMARC" ) {
1221         @listtags = ('345', '020');
1222         $subfield="c";
1223     } elsif ( $marcflavour eq "UNIMARC" ) {
1224         @listtags = ('345', '010');
1225         $subfield="d";
1226     } else {
1227         return;
1228     }
1229
1230     for my $field ( $record->field(@listtags) ) {
1231         for my $subfield_value  ($field->subfield($subfield)){
1232             #check value
1233             $subfield_value = MungeMarcPrice( $subfield_value );
1234             return $subfield_value if ($subfield_value);
1235         }
1236     }
1237     return 0; # no price found
1238 }
1239
1240 =head2 MungeMarcPrice
1241
1242 Return the best guess at what the actual price is from a price field.
1243
1244 =cut
1245
1246 sub MungeMarcPrice {
1247     my ( $price ) = @_;
1248     return unless ( $price =~ m/\d/ ); ## No digits means no price.
1249     # Look for the currency symbol and the normalized code of the active currency, if it's there,
1250     my $active_currency = Koha::Acquisition::Currencies->get_active;
1251     my $symbol = $active_currency->symbol;
1252     my $isocode = $active_currency->isocode;
1253     $isocode = $active_currency->currency unless defined $isocode;
1254     my $localprice;
1255     if ( $symbol ) {
1256         my @matches =($price=~ /
1257             \s?
1258             (                          # start of capturing parenthesis
1259             (?:
1260             (?:[\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'
1261             |(?:\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'
1262             )
1263             \s?\p{Sc}?\s?              # followed or not by a whitespace. \p{Sc}?\s? are for cases like '25$ USD'
1264             (?:
1265             (?:[\p{Sc}\p{L}\/.]){1,4}  # followed by same block as symbol block
1266             |(?:\d+[\p{P}\s]?){1,4}    # or by same block as digits block
1267             )
1268             \s?\p{L}{0,4}\s?           # followed or not by a whitespace. \p{L}{0,4}\s? are for cases like '$9.50 USD'
1269             )                          # end of capturing parenthesis
1270             (?:\p{P}|\z)               # followed by a punctuation sign or by the end of the string
1271             /gx);
1272
1273         if ( @matches ) {
1274             foreach ( @matches ) {
1275                 $localprice = $_ and last if index($_, $isocode)>=0;
1276             }
1277             if ( !$localprice ) {
1278                 foreach ( @matches ) {
1279                     $localprice = $_ and last if $_=~ /(^|[^\p{Sc}\p{L}\/])\Q$symbol\E([^\p{Sc}\p{L}\/]+\z|\z)/;
1280                 }
1281             }
1282         }
1283     }
1284     if ( $localprice ) {
1285         $price = $localprice;
1286     } else {
1287         ## Grab the first number in the string ( can use commas or periods for thousands separator and/or decimal separator )
1288         ( $price ) = $price =~ m/([\d\,\.]+[[\,\.]\d\d]?)/;
1289     }
1290     # eliminate symbol/isocode, space and any final dot from the string
1291     $price =~ s/[\p{Sc}\p{L}\/ ]|\.$//g;
1292     # remove comma,dot when used as separators from hundreds
1293     $price =~s/[\,\.](\d{3})/$1/g;
1294     # convert comma to dot to ensure correct display of decimals if existing
1295     $price =~s/,/./;
1296     return $price;
1297 }
1298
1299
1300 =head2 GetMarcQuantity
1301
1302 return the quantity of a book. Used in acquisition only, when importing a file an iso2709 from a bookseller
1303 Warning : this is not really in the marc standard. In Unimarc, Electre (the most widely used bookseller) use the 969$a
1304
1305 returns 0 if no quantity found
1306 returns undef if called without a marc record or with
1307 an unrecognized marc format
1308
1309 =cut
1310
1311 sub GetMarcQuantity {
1312     my ( $record, $marcflavour ) = @_;
1313     if (!$record) {
1314         carp 'GetMarcQuantity called on undefined record';
1315         return;
1316     }
1317
1318     my @listtags;
1319     my $subfield;
1320
1321     if ( $marcflavour eq "MARC21" ) {
1322         return 0
1323     } elsif ( $marcflavour eq "UNIMARC" ) {
1324         @listtags = ('969');
1325         $subfield="a";
1326     } else {
1327         return;
1328     }
1329
1330     for my $field ( $record->field(@listtags) ) {
1331         for my $subfield_value  ($field->subfield($subfield)){
1332             #check value
1333             if ($subfield_value) {
1334                  # in France, the cents separator is the , but sometimes, ppl use a .
1335                  # in this case, the price will be x100 when unformatted ! Replace the . by a , to get a proper price calculation
1336                 $subfield_value =~ s/\./,/ if C4::Context->preference("CurrencyFormat") eq "FR";
1337                 return $subfield_value;
1338             }
1339         }
1340     }
1341     return 0; # no price found
1342 }
1343
1344
1345 =head2 GetAuthorisedValueDesc
1346
1347   my $subfieldvalue =get_authorised_value_desc(
1348     $tag, $subf[$i][0],$subf[$i][1], '', $taglib, $category, $opac);
1349
1350 Retrieve the complete description for a given authorised value.
1351
1352 Now takes $category and $value pair too.
1353
1354   my $auth_value_desc =GetAuthorisedValueDesc(
1355     '','', 'DVD' ,'','','CCODE');
1356
1357 If the optional $opac parameter is set to a true value, displays OPAC
1358 descriptions rather than normal ones when they exist.
1359
1360 =cut
1361
1362 sub GetAuthorisedValueDesc {
1363     my ( $tag, $subfield, $value, $framework, $tagslib, $category, $opac ) = @_;
1364
1365     if ( !$category ) {
1366
1367         return $value unless defined $tagslib->{$tag}->{$subfield}->{'authorised_value'};
1368
1369         #---- branch
1370         if ( $tagslib->{$tag}->{$subfield}->{'authorised_value'} eq "branches" ) {
1371             my $branch = Koha::Libraries->find($value);
1372             return $branch? $branch->branchname: q{};
1373         }
1374
1375         #---- itemtypes
1376         if ( $tagslib->{$tag}->{$subfield}->{'authorised_value'} eq "itemtypes" ) {
1377             my $itemtype = Koha::ItemTypes->find( $value );
1378             return $itemtype ? $itemtype->translated_description : q||;
1379         }
1380
1381         #---- "true" authorized value
1382         $category = $tagslib->{$tag}->{$subfield}->{'authorised_value'};
1383     }
1384
1385     my $dbh = C4::Context->dbh;
1386     if ( $category ne "" ) {
1387         my $sth = $dbh->prepare( "SELECT lib, lib_opac FROM authorised_values WHERE category = ? AND authorised_value = ?" );
1388         $sth->execute( $category, $value );
1389         my $data = $sth->fetchrow_hashref;
1390         return ( $opac && $data->{'lib_opac'} ) ? $data->{'lib_opac'} : $data->{'lib'};
1391     } else {
1392         return $value;    # if nothing is found return the original value
1393     }
1394 }
1395
1396 =head2 GetMarcControlnumber
1397
1398   $marccontrolnumber = GetMarcControlnumber($record,$marcflavour);
1399
1400 Get the control number / record Identifier from the MARC record and return it.
1401
1402 =cut
1403
1404 sub GetMarcControlnumber {
1405     my ( $record, $marcflavour ) = @_;
1406     if (!$record) {
1407         carp 'GetMarcControlnumber called on undefined record';
1408         return;
1409     }
1410     my $controlnumber = "";
1411     # Control number or Record identifier are the same field in MARC21, UNIMARC and NORMARC
1412     # Keep $marcflavour for possible later use
1413     if ($marcflavour eq "MARC21" || $marcflavour eq "UNIMARC" || $marcflavour eq "NORMARC") {
1414         my $controlnumberField = $record->field('001');
1415         if ($controlnumberField) {
1416             $controlnumber = $controlnumberField->data();
1417         }
1418     }
1419     return $controlnumber;
1420 }
1421
1422 =head2 GetMarcISBN
1423
1424   $marcisbnsarray = GetMarcISBN( $record, $marcflavour );
1425
1426 Get all ISBNs from the MARC record and returns them in an array.
1427 ISBNs stored in different fields depending on MARC flavour
1428
1429 =cut
1430
1431 sub GetMarcISBN {
1432     my ( $record, $marcflavour ) = @_;
1433     if (!$record) {
1434         carp 'GetMarcISBN called on undefined record';
1435         return;
1436     }
1437     my $scope;
1438     if ( $marcflavour eq "UNIMARC" ) {
1439         $scope = '010';
1440     } else {    # assume marc21 if not unimarc
1441         $scope = '020';
1442     }
1443
1444     my @marcisbns;
1445     foreach my $field ( $record->field($scope) ) {
1446         my $isbn = $field->subfield( 'a' );
1447         if ( $isbn && $isbn ne "" ) {
1448             push @marcisbns, $isbn;
1449         }
1450     }
1451
1452     return \@marcisbns;
1453 }    # end GetMarcISBN
1454
1455
1456 =head2 GetMarcISSN
1457
1458   $marcissnsarray = GetMarcISSN( $record, $marcflavour );
1459
1460 Get all valid ISSNs from the MARC record and returns them in an array.
1461 ISSNs are stored in different fields depending on MARC flavour
1462
1463 =cut
1464
1465 sub GetMarcISSN {
1466     my ( $record, $marcflavour ) = @_;
1467     if (!$record) {
1468         carp 'GetMarcISSN called on undefined record';
1469         return;
1470     }
1471     my $scope;
1472     if ( $marcflavour eq "UNIMARC" ) {
1473         $scope = '011';
1474     }
1475     else {    # assume MARC21 or NORMARC
1476         $scope = '022';
1477     }
1478     my @marcissns;
1479     foreach my $field ( $record->field($scope) ) {
1480         push @marcissns, $field->subfield( 'a' )
1481             if ( $field->subfield( 'a' ) ne "" );
1482     }
1483     return \@marcissns;
1484 }    # end GetMarcISSN
1485
1486 =head2 GetMarcNotes
1487
1488     $marcnotesarray = GetMarcNotes( $record, $marcflavour );
1489
1490     Get all notes from the MARC record and returns them in an array.
1491     The notes are stored in different fields depending on MARC flavour.
1492     MARC21 5XX $u subfields receive special attention as they are URIs.
1493
1494 =cut
1495
1496 sub GetMarcNotes {
1497     my ( $record, $marcflavour, $opac ) = @_;
1498     if (!$record) {
1499         carp 'GetMarcNotes called on undefined record';
1500         return;
1501     }
1502
1503     my $scope = $marcflavour eq "UNIMARC"? '3..': '5..';
1504     my @marcnotes;
1505
1506     #MARC21 specs indicate some notes should be private if first indicator 0
1507     my %maybe_private = (
1508         541 => 1,
1509         542 => 1,
1510         561 => 1,
1511         583 => 1,
1512         590 => 1
1513     );
1514
1515     my %blacklist = map { $_ => 1 }
1516         split( /,/, C4::Context->preference('NotesBlacklist'));
1517     foreach my $field ( $record->field($scope) ) {
1518         my $tag = $field->tag();
1519         next if $blacklist{ $tag };
1520         next if $opac && $maybe_private{$tag} && !$field->indicator(1);
1521         if( $marcflavour ne 'UNIMARC' && $field->subfield('u') ) {
1522             # Field 5XX$u always contains URI
1523             # Examples: 505u, 506u, 510u, 514u, 520u, 530u, 538u, 540u, 542u, 552u, 555u, 561u, 563u, 583u
1524             # We first push the other subfields, then all $u's separately
1525             # Leave further actions to the template (see e.g. opac-detail)
1526             my $othersub =
1527                 join '', ( 'a' .. 't', 'v' .. 'z', '0' .. '9' ); # excl 'u'
1528             push @marcnotes, { marcnote => $field->as_string($othersub) };
1529             foreach my $sub ( $field->subfield('u') ) {
1530                 $sub =~ s/^\s+|\s+$//g; # trim
1531                 push @marcnotes, { marcnote => $sub };
1532             }
1533         } else {
1534             push @marcnotes, { marcnote => $field->as_string() };
1535         }
1536     }
1537     return \@marcnotes;
1538 }
1539
1540 =head2 GetMarcSubjects
1541
1542   $marcsubjcts = GetMarcSubjects($record,$marcflavour);
1543
1544 Get all subjects from the MARC record and returns them in an array.
1545 The subjects are stored in different fields depending on MARC flavour
1546
1547 =cut
1548
1549 sub GetMarcSubjects {
1550     my ( $record, $marcflavour ) = @_;
1551     if (!$record) {
1552         carp 'GetMarcSubjects called on undefined record';
1553         return;
1554     }
1555     my ( $mintag, $maxtag, $fields_filter );
1556     if ( $marcflavour eq "UNIMARC" ) {
1557         $mintag = "600";
1558         $maxtag = "611";
1559         $fields_filter = '6..';
1560     } else { # marc21/normarc
1561         $mintag = "600";
1562         $maxtag = "699";
1563         $fields_filter = '6..';
1564     }
1565
1566     my @marcsubjects;
1567
1568     my $subject_limit = C4::Context->preference("TraceCompleteSubfields") ? 'su,complete-subfield' : 'su';
1569     my $AuthoritySeparator = C4::Context->preference('AuthoritySeparator');
1570
1571     foreach my $field ( $record->field($fields_filter) ) {
1572         next unless ($field->tag() >= $mintag && $field->tag() <= $maxtag);
1573         my @subfields_loop;
1574         my @subfields = $field->subfields();
1575         my @link_loop;
1576
1577         # if there is an authority link, build the links with an= subfield9
1578         my $subfield9 = $field->subfield('9');
1579         my $authoritylink;
1580         if ($subfield9) {
1581             my $linkvalue = $subfield9;
1582             $linkvalue =~ s/(\(|\))//g;
1583             @link_loop = ( { limit => 'an', 'link' => $linkvalue } );
1584             $authoritylink = $linkvalue
1585         }
1586
1587         # other subfields
1588         for my $subject_subfield (@subfields) {
1589             next if ( $subject_subfield->[0] eq '9' );
1590
1591             # don't load unimarc subfields 3,4,5
1592             next if ( ( $marcflavour eq "UNIMARC" ) and ( $subject_subfield->[0] =~ /2|3|4|5/ ) );
1593             # don't load MARC21 subfields 2 (FIXME: any more subfields??)
1594             next if ( ( $marcflavour eq "MARC21" ) and ( $subject_subfield->[0] =~ /2/ ) );
1595
1596             my $code      = $subject_subfield->[0];
1597             my $value     = $subject_subfield->[1];
1598             my $linkvalue = $value;
1599             $linkvalue =~ s/(\(|\))//g;
1600             # if no authority link, build a search query
1601             unless ($subfield9) {
1602                 push @link_loop, {
1603                     limit    => $subject_limit,
1604                     'link'   => $linkvalue,
1605                     operator => (scalar @link_loop) ? ' and ' : undef
1606                 };
1607             }
1608             my @this_link_loop = @link_loop;
1609             # do not display $0
1610             unless ( $code eq '0' ) {
1611                 push @subfields_loop, {
1612                     code      => $code,
1613                     value     => $value,
1614                     link_loop => \@this_link_loop,
1615                     separator => (scalar @subfields_loop) ? $AuthoritySeparator : ''
1616                 };
1617             }
1618         }
1619
1620         push @marcsubjects, {
1621             MARCSUBJECT_SUBFIELDS_LOOP => \@subfields_loop,
1622             authoritylink => $authoritylink,
1623         } if $authoritylink || @subfields_loop;
1624
1625     }
1626     return \@marcsubjects;
1627 }    #end getMARCsubjects
1628
1629 =head2 GetMarcAuthors
1630
1631   authors = GetMarcAuthors($record,$marcflavour);
1632
1633 Get all authors from the MARC record and returns them in an array.
1634 The authors are stored in different fields depending on MARC flavour
1635
1636 =cut
1637
1638 sub GetMarcAuthors {
1639     my ( $record, $marcflavour ) = @_;
1640     if (!$record) {
1641         carp 'GetMarcAuthors called on undefined record';
1642         return;
1643     }
1644     my ( $mintag, $maxtag, $fields_filter );
1645
1646     # tagslib useful only for UNIMARC author responsibilities
1647     my $tagslib;
1648     if ( $marcflavour eq "UNIMARC" ) {
1649         # FIXME : we don't have the framework available, we take the default framework. May be buggy on some setups, will be usually correct.
1650         $tagslib = GetMarcStructure( 1, '', { unsafe => 1 });
1651         $mintag = "700";
1652         $maxtag = "712";
1653         $fields_filter = '7..';
1654     } else { # marc21/normarc
1655         $mintag = "700";
1656         $maxtag = "720";
1657         $fields_filter = '7..';
1658     }
1659
1660     my @marcauthors;
1661     my $AuthoritySeparator = C4::Context->preference('AuthoritySeparator');
1662
1663     foreach my $field ( $record->field($fields_filter) ) {
1664         next unless $field->tag() >= $mintag && $field->tag() <= $maxtag;
1665         my @subfields_loop;
1666         my @link_loop;
1667         my @subfields  = $field->subfields();
1668         my $count_auth = 0;
1669
1670         # if there is an authority link, build the link with Koha-Auth-Number: subfield9
1671         my $subfield9 = $field->subfield('9');
1672         if ($subfield9) {
1673             my $linkvalue = $subfield9;
1674             $linkvalue =~ s/(\(|\))//g;
1675             @link_loop = ( { 'limit' => 'an', 'link' => $linkvalue } );
1676         }
1677
1678         # other subfields
1679         my $unimarc3;
1680         for my $authors_subfield (@subfields) {
1681             next if ( $authors_subfield->[0] eq '9' );
1682
1683             # unimarc3 contains the $3 of the author for UNIMARC.
1684             # For french academic libraries, it's the "ppn", and it's required for idref webservice
1685             $unimarc3 = $authors_subfield->[1] if $marcflavour eq 'UNIMARC' and $authors_subfield->[0] =~ /3/;
1686
1687             # don't load unimarc subfields 3, 5
1688             next if ( $marcflavour eq 'UNIMARC' and ( $authors_subfield->[0] =~ /3|5/ ) );
1689
1690             my $code = $authors_subfield->[0];
1691             my $value        = $authors_subfield->[1];
1692             my $linkvalue    = $value;
1693             $linkvalue =~ s/(\(|\))//g;
1694             # UNIMARC author responsibility
1695             if ( $marcflavour eq 'UNIMARC' and $code eq '4' ) {
1696                 $value = GetAuthorisedValueDesc( $field->tag(), $code, $value, '', $tagslib );
1697                 $linkvalue = "($value)";
1698             }
1699             # if no authority link, build a search query
1700             unless ($subfield9) {
1701                 push @link_loop, {
1702                     limit    => 'au',
1703                     'link'   => $linkvalue,
1704                     operator => (scalar @link_loop) ? ' and ' : undef
1705                 };
1706             }
1707             my @this_link_loop = @link_loop;
1708             # do not display $0
1709             unless ( $code eq '0') {
1710                 push @subfields_loop, {
1711                     tag       => $field->tag(),
1712                     code      => $code,
1713                     value     => $value,
1714                     link_loop => \@this_link_loop,
1715                     separator => (scalar @subfields_loop) ? $AuthoritySeparator : ''
1716                 };
1717             }
1718         }
1719         push @marcauthors, {
1720             MARCAUTHOR_SUBFIELDS_LOOP => \@subfields_loop,
1721             authoritylink => $subfield9,
1722             unimarc3 => $unimarc3
1723         };
1724     }
1725     return \@marcauthors;
1726 }
1727
1728 =head2 GetMarcUrls
1729
1730   $marcurls = GetMarcUrls($record,$marcflavour);
1731
1732 Returns arrayref of URLs from MARC data, suitable to pass to tmpl loop.
1733 Assumes web resources (not uncommon in MARC21 to omit resource type ind)
1734
1735 =cut
1736
1737 sub GetMarcUrls {
1738     my ( $record, $marcflavour ) = @_;
1739     if (!$record) {
1740         carp 'GetMarcUrls called on undefined record';
1741         return;
1742     }
1743
1744     my @marcurls;
1745     for my $field ( $record->field('856') ) {
1746         my @notes;
1747         for my $note ( $field->subfield('z') ) {
1748             push @notes, { note => $note };
1749         }
1750         my @urls = $field->subfield('u');
1751         foreach my $url (@urls) {
1752             $url =~ s/^\s+|\s+$//g; # trim
1753             my $marcurl;
1754             if ( $marcflavour eq 'MARC21' ) {
1755                 my $s3   = $field->subfield('3');
1756                 my $link = $field->subfield('y');
1757                 unless ( $url =~ /^\w+:/ ) {
1758                     if ( $field->indicator(1) eq '7' ) {
1759                         $url = $field->subfield('2') . "://" . $url;
1760                     } elsif ( $field->indicator(1) eq '1' ) {
1761                         $url = 'ftp://' . $url;
1762                     } else {
1763
1764                         #  properly, this should be if ind1=4,
1765                         #  however we will assume http protocol since we're building a link.
1766                         $url = 'http://' . $url;
1767                     }
1768                 }
1769
1770                 # TODO handle ind 2 (relationship)
1771                 $marcurl = {
1772                     MARCURL => $url,
1773                     notes   => \@notes,
1774                 };
1775                 $marcurl->{'linktext'} = $link || $s3 || C4::Context->preference('URLLinkText') || $url;
1776                 $marcurl->{'part'} = $s3 if ($link);
1777                 $marcurl->{'toc'} = 1 if ( defined($s3) && $s3 =~ /^[Tt]able/ );
1778             } else {
1779                 $marcurl->{'linktext'} = $field->subfield('2') || C4::Context->preference('URLLinkText') || $url;
1780                 $marcurl->{'MARCURL'} = $url;
1781             }
1782             push @marcurls, $marcurl;
1783         }
1784     }
1785     return \@marcurls;
1786 }
1787
1788 =head2 GetMarcSeries
1789
1790   $marcseriesarray = GetMarcSeries($record,$marcflavour);
1791
1792 Get all series from the MARC record and returns them in an array.
1793 The series are stored in different fields depending on MARC flavour
1794
1795 =cut
1796
1797 sub GetMarcSeries {
1798     my ( $record, $marcflavour ) = @_;
1799     if (!$record) {
1800         carp 'GetMarcSeries called on undefined record';
1801         return;
1802     }
1803
1804     my ( $mintag, $maxtag, $fields_filter );
1805     if ( $marcflavour eq "UNIMARC" ) {
1806         $mintag = "225";
1807         $maxtag = "225";
1808         $fields_filter = '2..';
1809     } else {    # marc21/normarc
1810         $mintag = "440";
1811         $maxtag = "490";
1812         $fields_filter = '4..';
1813     }
1814
1815     my @marcseries;
1816     my $AuthoritySeparator = C4::Context->preference('AuthoritySeparator');
1817
1818     foreach my $field ( $record->field($fields_filter) ) {
1819         next unless $field->tag() >= $mintag && $field->tag() <= $maxtag;
1820         my @subfields_loop;
1821         my @subfields = $field->subfields();
1822         my @link_loop;
1823
1824         for my $series_subfield (@subfields) {
1825
1826             # ignore $9, used for authority link
1827             next if ( $series_subfield->[0] eq '9' );
1828
1829             my $volume_number;
1830             my $code      = $series_subfield->[0];
1831             my $value     = $series_subfield->[1];
1832             my $linkvalue = $value;
1833             $linkvalue =~ s/(\(|\))//g;
1834
1835             # see if this is an instance of a volume
1836             if ( $code eq 'v' ) {
1837                 $volume_number = 1;
1838             }
1839
1840             push @link_loop, {
1841                 'link' => $linkvalue,
1842                 operator => (scalar @link_loop) ? ' and ' : undef
1843             };
1844
1845             if ($volume_number) {
1846                 push @subfields_loop, { volumenum => $value };
1847             } else {
1848                 push @subfields_loop, {
1849                     code      => $code,
1850                     value     => $value,
1851                     link_loop => \@link_loop,
1852                     separator => (scalar @subfields_loop) ? $AuthoritySeparator : '',
1853                     volumenum => $volume_number,
1854                 }
1855             }
1856         }
1857         push @marcseries, { MARCSERIES_SUBFIELDS_LOOP => \@subfields_loop };
1858
1859     }
1860     return \@marcseries;
1861 }    #end getMARCseriess
1862
1863 =head2 GetMarcHosts
1864
1865   $marchostsarray = GetMarcHosts($record,$marcflavour);
1866
1867 Get all host records (773s MARC21, 461 UNIMARC) from the MARC record and returns them in an array.
1868
1869 =cut
1870
1871 sub GetMarcHosts {
1872     my ( $record, $marcflavour ) = @_;
1873     if (!$record) {
1874         carp 'GetMarcHosts called on undefined record';
1875         return;
1876     }
1877
1878     my ( $tag,$title_subf,$bibnumber_subf,$itemnumber_subf);
1879     $marcflavour ||="MARC21";
1880     if ( $marcflavour eq "MARC21" || $marcflavour eq "NORMARC" ) {
1881         $tag = "773";
1882         $title_subf = "t";
1883         $bibnumber_subf ="0";
1884         $itemnumber_subf='9';
1885     }
1886     elsif ($marcflavour eq "UNIMARC") {
1887         $tag = "461";
1888         $title_subf = "t";
1889         $bibnumber_subf ="0";
1890         $itemnumber_subf='9';
1891     };
1892
1893     my @marchosts;
1894
1895     foreach my $field ( $record->field($tag)) {
1896
1897         my @fields_loop;
1898
1899         my $hostbiblionumber = $field->subfield("$bibnumber_subf");
1900         my $hosttitle = $field->subfield($title_subf);
1901         my $hostitemnumber=$field->subfield($itemnumber_subf);
1902         push @fields_loop, { hostbiblionumber => $hostbiblionumber, hosttitle => $hosttitle, hostitemnumber => $hostitemnumber};
1903         push @marchosts, { MARCHOSTS_FIELDS_LOOP => \@fields_loop };
1904
1905         }
1906     my $marchostsarray = \@marchosts;
1907     return $marchostsarray;
1908 }
1909
1910 =head2 UpsertMarcSubfield
1911
1912     my $record = C4::Biblio::UpsertMarcSubfield($MARC::Record, $fieldTag, $subfieldCode, $subfieldContent);
1913
1914 =cut
1915
1916 sub UpsertMarcSubfield {
1917     my ($record, $tag, $code, $content) = @_;
1918     my $f = $record->field($tag);
1919
1920     if ($f) {
1921         $f->update( $code => $content );
1922     }
1923     else {
1924         my $f = MARC::Field->new( $tag, '', '', $code => $content);
1925         $record->insert_fields_ordered( $f );
1926     }
1927 }
1928
1929 =head2 UpsertMarcControlField
1930
1931     my $record = C4::Biblio::UpsertMarcControlField($MARC::Record, $fieldTag, $content);
1932
1933 =cut
1934
1935 sub UpsertMarcControlField {
1936     my ($record, $tag, $content) = @_;
1937     die "UpsertMarcControlField() \$tag '$tag' is not a control field\n" unless 0+$tag < 10;
1938     my $f = $record->field($tag);
1939
1940     if ($f) {
1941         $f->update( $content );
1942     }
1943     else {
1944         my $f = MARC::Field->new($tag, $content);
1945         $record->insert_fields_ordered( $f );
1946     }
1947 }
1948
1949 =head2 GetFrameworkCode
1950
1951   $frameworkcode = GetFrameworkCode( $biblionumber )
1952
1953 =cut
1954
1955 sub GetFrameworkCode {
1956     my ($biblionumber) = @_;
1957     my $dbh            = C4::Context->dbh;
1958     my $sth            = $dbh->prepare("SELECT frameworkcode FROM biblio WHERE biblionumber=?");
1959     $sth->execute($biblionumber);
1960     my ($frameworkcode) = $sth->fetchrow;
1961     return $frameworkcode;
1962 }
1963
1964 =head2 TransformKohaToMarc
1965
1966     $record = TransformKohaToMarc( $hash [, $params ]  )
1967
1968 This function builds a (partial) MARC::Record from a hash.
1969 Hash entries can be from biblio, biblioitems or items.
1970 The params hash includes the parameter no_split used in C4::Items.
1971
1972 This function is called in acquisition module, to create a basic catalogue
1973 entry from user entry.
1974
1975 =cut
1976
1977
1978 sub TransformKohaToMarc {
1979     my ( $hash, $params ) = @_;
1980     my $record = MARC::Record->new();
1981     SetMarcUnicodeFlag( $record, C4::Context->preference("marcflavour") );
1982
1983     # In the next call we use the Default framework, since it is considered
1984     # authoritative for Koha to Marc mappings.
1985     my $mss = GetMarcSubfieldStructure( '', { unsafe => 1 } ); # do not change framewok
1986     my $tag_hr = {};
1987     while ( my ($kohafield, $value) = each %$hash ) {
1988         foreach my $fld ( @{ $mss->{$kohafield} } ) {
1989             my $tagfield    = $fld->{tagfield};
1990             my $tagsubfield = $fld->{tagsubfield};
1991             next if !$tagfield;
1992             my @values = $params->{no_split}
1993                 ? ( $value )
1994                 : split(/\s?\|\s?/, $value, -1);
1995             foreach my $value ( @values ) {
1996                 next if $value eq '';
1997                 $tag_hr->{$tagfield} //= [];
1998                 push @{$tag_hr->{$tagfield}}, [($tagsubfield, $value)];
1999             }
2000         }
2001     }
2002     foreach my $tag (sort keys %$tag_hr) {
2003         my @sfl = @{$tag_hr->{$tag}};
2004         @sfl = sort { $a->[0] cmp $b->[0]; } @sfl;
2005         @sfl = map { @{$_}; } @sfl;
2006         # Special care for control fields: remove the subfield indication @
2007         # and do not insert indicators.
2008         my @ind = $tag < 10 ? () : ( " ", " " );
2009         @sfl = grep { $_ ne '@' } @sfl if $tag < 10;
2010         $record->insert_fields_ordered( MARC::Field->new($tag, @ind, @sfl) );
2011     }
2012     return $record;
2013 }
2014
2015 =head2 PrepHostMarcField
2016
2017     $hostfield = PrepHostMarcField ( $hostbiblionumber,$hostitemnumber,$marcflavour )
2018
2019 This function returns a host field populated with data from the host record, the field can then be added to an analytical record
2020
2021 =cut
2022
2023 sub PrepHostMarcField {
2024     my ($hostbiblionumber,$hostitemnumber, $marcflavour) = @_;
2025     $marcflavour ||="MARC21";
2026
2027     my $hostrecord = GetMarcBiblio({ biblionumber => $hostbiblionumber });
2028     my $item = Koha::Items->find($hostitemnumber);
2029
2030         my $hostmarcfield;
2031     if ( $marcflavour eq "MARC21" || $marcflavour eq "NORMARC" ) {
2032
2033         #main entry
2034         my $mainentry;
2035         if ($hostrecord->subfield('100','a')){
2036             $mainentry = $hostrecord->subfield('100','a');
2037         } elsif ($hostrecord->subfield('110','a')){
2038             $mainentry = $hostrecord->subfield('110','a');
2039         } else {
2040             $mainentry = $hostrecord->subfield('111','a');
2041         }
2042
2043         # qualification info
2044         my $qualinfo;
2045         if (my $field260 = $hostrecord->field('260')){
2046             $qualinfo =  $field260->as_string( 'abc' );
2047         }
2048
2049
2050         #other fields
2051         my $ed = $hostrecord->subfield('250','a');
2052         my $barcode = $item->barcode;
2053         my $title = $hostrecord->subfield('245','a');
2054
2055         # record control number, 001 with 003 and prefix
2056         my $recctrlno;
2057         if ($hostrecord->field('001')){
2058             $recctrlno = $hostrecord->field('001')->data();
2059             if ($hostrecord->field('003')){
2060                 $recctrlno = '('.$hostrecord->field('003')->data().')'.$recctrlno;
2061             }
2062         }
2063
2064         # issn/isbn
2065         my $issn = $hostrecord->subfield('022','a');
2066         my $isbn = $hostrecord->subfield('020','a');
2067
2068
2069         $hostmarcfield = MARC::Field->new(
2070                 773, '0', '',
2071                 '0' => $hostbiblionumber,
2072                 '9' => $hostitemnumber,
2073                 'a' => $mainentry,
2074                 'b' => $ed,
2075                 'd' => $qualinfo,
2076                 'o' => $barcode,
2077                 't' => $title,
2078                 'w' => $recctrlno,
2079                 'x' => $issn,
2080                 'z' => $isbn
2081                 );
2082     } elsif ($marcflavour eq "UNIMARC") {
2083         $hostmarcfield = MARC::Field->new(
2084             461, '', '',
2085             '0' => $hostbiblionumber,
2086             't' => $hostrecord->subfield('200','a'),
2087             '9' => $hostitemnumber
2088         );
2089     };
2090
2091     return $hostmarcfield;
2092 }
2093
2094 =head2 TransformHtmlToXml
2095
2096   $xml = TransformHtmlToXml( $tags, $subfields, $values, $indicator,
2097                              $ind_tag, $auth_type )
2098
2099 $auth_type contains :
2100
2101 =over
2102
2103 =item - nothing : rebuild a biblio. In UNIMARC the encoding is in 100$a pos 26/27
2104
2105 =item - UNIMARCAUTH : rebuild an authority. In UNIMARC, the encoding is in 100$a pos 13/14
2106
2107 =item - ITEM : rebuild an item : in UNIMARC, 100$a, it's in the biblio ! (otherwise, we would get 2 100 fields !)
2108
2109 =back
2110
2111 =cut
2112
2113 sub TransformHtmlToXml {
2114     my ( $tags, $subfields, $values, $indicator, $ind_tag, $auth_type ) = @_;
2115     # NOTE: The parameter $ind_tag is NOT USED -- BZ 11247
2116
2117     my $xml = MARC::File::XML::header('UTF-8');
2118     $xml .= "<record>\n";
2119     $auth_type = C4::Context->preference('marcflavour') unless $auth_type;
2120     MARC::File::XML->default_record_format($auth_type);
2121
2122     # in UNIMARC, field 100 contains the encoding
2123     # check that there is one, otherwise the
2124     # MARC::Record->new_from_xml will fail (and Koha will die)
2125     my $unimarc_and_100_exist = 0;
2126     $unimarc_and_100_exist = 1 if $auth_type eq 'ITEM';    # if we rebuild an item, no need of a 100 field
2127     my $prevvalue;
2128     my $prevtag = -1;
2129     my $first   = 1;
2130     my $j       = -1;
2131     my $close_last_tag;
2132     for ( my $i = 0 ; $i < @$tags ; $i++ ) {
2133
2134         if ( C4::Context->preference('marcflavour') eq 'UNIMARC' and @$tags[$i] eq "100" and @$subfields[$i] eq "a" ) {
2135
2136             # if we have a 100 field and it's values are not correct, skip them.
2137             # if we don't have any valid 100 field, we will create a default one at the end
2138             my $enc = substr( @$values[$i], 26, 2 );
2139             if ( $enc eq '01' or $enc eq '50' or $enc eq '03' ) {
2140                 $unimarc_and_100_exist = 1;
2141             } else {
2142                 next;
2143             }
2144         }
2145         @$values[$i] =~ s/&/&amp;/g;
2146         @$values[$i] =~ s/</&lt;/g;
2147         @$values[$i] =~ s/>/&gt;/g;
2148         @$values[$i] =~ s/"/&quot;/g;
2149         @$values[$i] =~ s/'/&apos;/g;
2150
2151         if ( ( @$tags[$i] ne $prevtag ) ) {
2152             $close_last_tag = 0;
2153             $j++ unless ( @$tags[$i] eq "" );
2154             my $str = ( $indicator->[$j] // q{} ) . '  '; # extra space prevents substr outside of string warn
2155             my $ind1 = _default_ind_to_space( substr( $str, 0, 1 ) );
2156             my $ind2 = _default_ind_to_space( substr( $str, 1, 1 ) );
2157             if ( !$first ) {
2158                 $xml .= "</datafield>\n";
2159                 if (   ( @$tags[$i] && @$tags[$i] > 10 )
2160                     && ( @$values[$i] ne "" ) ) {
2161                     $xml .= "<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
2162                     $xml .= "<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
2163                     $first = 0;
2164                     $close_last_tag = 1;
2165                 } else {
2166                     $first = 1;
2167                 }
2168             } else {
2169                 if ( @$values[$i] ne "" ) {
2170
2171                     # leader
2172                     if ( @$tags[$i] eq "000" ) {
2173                         $xml .= "<leader>@$values[$i]</leader>\n";
2174                         $first = 1;
2175
2176                         # rest of the fixed fields
2177                     } elsif ( @$tags[$i] < 10 ) {
2178                         $xml .= "<controlfield tag=\"@$tags[$i]\">@$values[$i]</controlfield>\n";
2179                         $first = 1;
2180                     } else {
2181                         $xml .= "<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
2182                         $xml .= "<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
2183                         $first = 0;
2184                         $close_last_tag = 1;
2185                     }
2186                 }
2187             }
2188         } else {    # @$tags[$i] eq $prevtag
2189             if ( @$values[$i] eq "" ) {
2190             } else {
2191                 if ($first) {
2192                     my $str = ( $indicator->[$j] // q{} ) . '  '; # extra space prevents substr outside of string warn
2193                     my $ind1 = _default_ind_to_space( substr( $str, 0, 1 ) );
2194                     my $ind2 = _default_ind_to_space( substr( $str, 1, 1 ) );
2195                     $xml .= "<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
2196                     $first = 0;
2197                     $close_last_tag = 1;
2198                 }
2199                 $xml .= "<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
2200             }
2201         }
2202         $prevtag = @$tags[$i];
2203     }
2204     $xml .= "</datafield>\n" if $close_last_tag;
2205     if ( C4::Context->preference('marcflavour') eq 'UNIMARC' and !$unimarc_and_100_exist ) {
2206
2207         #     warn "SETTING 100 for $auth_type";
2208         my $string = strftime( "%Y%m%d", localtime(time) );
2209
2210         # set 50 to position 26 is biblios, 13 if authorities
2211         my $pos = 26;
2212         $pos = 13 if $auth_type eq 'UNIMARCAUTH';
2213         $string = sprintf( "%-*s", 35, $string );
2214         substr( $string, $pos, 6, "50" );
2215         $xml .= "<datafield tag=\"100\" ind1=\"\" ind2=\"\">\n";
2216         $xml .= "<subfield code=\"a\">$string</subfield>\n";
2217         $xml .= "</datafield>\n";
2218     }
2219     $xml .= "</record>\n";
2220     $xml .= MARC::File::XML::footer();
2221     return $xml;
2222 }
2223
2224 =head2 _default_ind_to_space
2225
2226 Passed what should be an indicator returns a space
2227 if its undefined or zero length
2228
2229 =cut
2230
2231 sub _default_ind_to_space {
2232     my $s = shift;
2233     if ( !defined $s || $s eq q{} ) {
2234         return ' ';
2235     }
2236     return $s;
2237 }
2238
2239 =head2 TransformHtmlToMarc
2240
2241     L<$record> = TransformHtmlToMarc(L<$cgi>)
2242     L<$cgi> is the CGI object which contains the values for subfields
2243     {
2244         'tag_010_indicator1_531951' ,
2245         'tag_010_indicator2_531951' ,
2246         'tag_010_code_a_531951_145735' ,
2247         'tag_010_subfield_a_531951_145735' ,
2248         'tag_200_indicator1_873510' ,
2249         'tag_200_indicator2_873510' ,
2250         'tag_200_code_a_873510_673465' ,
2251         'tag_200_subfield_a_873510_673465' ,
2252         'tag_200_code_b_873510_704318' ,
2253         'tag_200_subfield_b_873510_704318' ,
2254         'tag_200_code_e_873510_280822' ,
2255         'tag_200_subfield_e_873510_280822' ,
2256         'tag_200_code_f_873510_110730' ,
2257         'tag_200_subfield_f_873510_110730' ,
2258     }
2259     L<$record> is the MARC::Record object.
2260
2261 =cut
2262
2263 sub TransformHtmlToMarc {
2264     my ($cgi, $isbiblio) = @_;
2265
2266     my @params = $cgi->multi_param();
2267
2268     # explicitly turn on the UTF-8 flag for all
2269     # 'tag_' parameters to avoid incorrect character
2270     # conversion later on
2271     my $cgi_params = $cgi->Vars;
2272     foreach my $param_name ( keys %$cgi_params ) {
2273         if ( $param_name =~ /^tag_/ ) {
2274             my $param_value = $cgi_params->{$param_name};
2275             unless ( Encode::is_utf8( $param_value ) ) {
2276                 $cgi_params->{$param_name} = Encode::decode('UTF-8', $param_value );
2277             }
2278         }
2279     }
2280
2281     # creating a new record
2282     my $record = MARC::Record->new();
2283     my @fields;
2284     my ($biblionumbertagfield, $biblionumbertagsubfield) = (-1, -1);
2285     ($biblionumbertagfield, $biblionumbertagsubfield) =
2286         &GetMarcFromKohaField( "biblio.biblionumber", '' ) if $isbiblio;
2287 #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!
2288     for (my $i = 0; $params[$i]; $i++ ) {    # browse all CGI params
2289         my $param    = $params[$i];
2290         my $newfield = 0;
2291
2292         # if we are on biblionumber, store it in the MARC::Record (it may not be in the edited fields)
2293         if ( $param eq 'biblionumber' ) {
2294             if ( $biblionumbertagfield < 10 ) {
2295                 $newfield = MARC::Field->new( $biblionumbertagfield, scalar $cgi->param($param), );
2296             } else {
2297                 $newfield = MARC::Field->new( $biblionumbertagfield, '', '', "$biblionumbertagsubfield" => scalar $cgi->param($param), );
2298             }
2299             push @fields, $newfield if ($newfield);
2300         } elsif ( $param =~ /^tag_(\d*)_indicator1_/ ) {    # new field start when having 'input name="..._indicator1_..."
2301             my $tag = $1;
2302
2303             my $ind1 = _default_ind_to_space( substr( $cgi->param($param), 0, 1 ) );
2304             my $ind2 = _default_ind_to_space( substr( $cgi->param( $params[ $i + 1 ] ), 0, 1 ) );
2305             $newfield = 0;
2306             my $j = $i + 2;
2307
2308             if ( $tag < 10 ) {                              # no code for theses fields
2309                                                             # in MARC editor, 000 contains the leader.
2310                 next if $tag == $biblionumbertagfield;
2311                 my $fval= $cgi->param($params[$j+1]);
2312                 if ( $tag eq '000' ) {
2313                     # Force a fake leader even if not provided to avoid crashing
2314                     # during decoding MARC record containing UTF-8 characters
2315                     $record->leader(
2316                         length( $fval ) == 24
2317                         ? $fval
2318                         : '     nam a22        4500'
2319                         )
2320                     ;
2321                     # between 001 and 009 (included)
2322                 } elsif ( $fval ne '' ) {
2323                     $newfield = MARC::Field->new( $tag, $fval, );
2324                 }
2325
2326                 # > 009, deal with subfields
2327             } else {
2328                 # browse subfields for this tag (reason for _code_ match)
2329                 while(defined $params[$j] && $params[$j] =~ /_code_/) {
2330                     last unless defined $params[$j+1];
2331                     $j += 2 and next
2332                         if $tag == $biblionumbertagfield and
2333                            $cgi->param($params[$j]) eq $biblionumbertagsubfield;
2334                     #if next param ne subfield, then it was probably empty
2335                     #try next param by incrementing j
2336                     if($params[$j+1]!~/_subfield_/) {$j++; next; }
2337                     my $fkey= $cgi->param($params[$j]);
2338                     my $fval= $cgi->param($params[$j+1]);
2339                     #check if subfield value not empty and field exists
2340                     if($fval ne '' && $newfield) {
2341                         $newfield->add_subfields( $fkey => $fval);
2342                     }
2343                     elsif($fval ne '') {
2344                         $newfield = MARC::Field->new( $tag, $ind1, $ind2, $fkey => $fval );
2345                     }
2346                     $j += 2;
2347                 } #end-of-while
2348                 $i= $j-1; #update i for outer loop accordingly
2349             }
2350             push @fields, $newfield if ($newfield);
2351         }
2352     }
2353
2354     $record->append_fields(@fields);
2355     return $record;
2356 }
2357
2358 =head2 TransformMarcToKoha
2359
2360     $result = TransformMarcToKoha( $record, undef, $limit )
2361
2362 Extract data from a MARC bib record into a hashref representing
2363 Koha biblio, biblioitems, and items fields.
2364
2365 If passed an undefined record will log the error and return an empty
2366 hash_ref.
2367
2368 =cut
2369
2370 sub TransformMarcToKoha {
2371     my ( $record, $frameworkcode, $limit_table ) = @_;
2372     # FIXME  Parameter $frameworkcode is obsolete and will be removed
2373     $limit_table //= q{};
2374
2375     my $result = {};
2376     if (!defined $record) {
2377         carp('TransformMarcToKoha called with undefined record');
2378         return $result;
2379     }
2380
2381     my %tables = ( biblio => 1, biblioitems => 1, items => 1 );
2382     if( $limit_table eq 'items' ) {
2383         %tables = ( items => 1 );
2384     }
2385
2386     # The next call acknowledges Default as the authoritative framework
2387     # for Koha to MARC mappings.
2388     my $mss = GetMarcSubfieldStructure( '', { unsafe => 1 } ); # Do not change framework
2389     foreach my $kohafield ( keys %{ $mss } ) {
2390         my ( $table, $column ) = split /[.]/, $kohafield, 2;
2391         next unless $tables{$table};
2392         my $val = TransformMarcToKohaOneField( $kohafield, $record );
2393         next if !defined $val;
2394         my $key = _disambiguate( $table, $column );
2395         $result->{$key} = $val;
2396     }
2397     return $result;
2398 }
2399
2400 =head2 _disambiguate
2401
2402   $newkey = _disambiguate($table, $field);
2403
2404 This is a temporary hack to distinguish between the
2405 following sets of columns when using TransformMarcToKoha.
2406
2407   items.cn_source & biblioitems.cn_source
2408   items.cn_sort & biblioitems.cn_sort
2409
2410 Columns that are currently NOT distinguished (FIXME
2411 due to lack of time to fully test) are:
2412
2413   biblio.notes and biblioitems.notes
2414   biblionumber
2415   timestamp
2416   biblioitemnumber
2417
2418 FIXME - this is necessary because prefixing each column
2419 name with the table name would require changing lots
2420 of code and templates, and exposing more of the DB
2421 structure than is good to the UI templates, particularly
2422 since biblio and bibloitems may well merge in a future
2423 version.  In the future, it would also be good to
2424 separate DB access and UI presentation field names
2425 more.
2426
2427 =cut
2428
2429 sub _disambiguate {
2430     my ( $table, $column ) = @_;
2431     if ( $column eq "cn_sort" or $column eq "cn_source" ) {
2432         return $table . '.' . $column;
2433     } else {
2434         return $column;
2435     }
2436
2437 }
2438
2439 =head2 TransformMarcToKohaOneField
2440
2441     $val = TransformMarcToKohaOneField( 'biblio.title', $marc );
2442
2443     Note: The authoritative Default framework is used implicitly.
2444
2445 =cut
2446
2447 sub TransformMarcToKohaOneField {
2448     my ( $kohafield, $marc ) = @_;
2449
2450     my ( @rv, $retval );
2451     my @mss = GetMarcSubfieldStructureFromKohaField($kohafield);
2452     foreach my $fldhash ( @mss ) {
2453         my $tag = $fldhash->{tagfield};
2454         my $sub = $fldhash->{tagsubfield};
2455         foreach my $fld ( $marc->field($tag) ) {
2456             if( $sub eq '@' || $fld->is_control_field ) {
2457                 push @rv, $fld->data if $fld->data;
2458             } else {
2459                 push @rv, grep { $_ } $fld->subfield($sub);
2460             }
2461         }
2462     }
2463     return unless @rv;
2464     $retval = join ' | ', uniq(@rv);
2465
2466     # Additional polishing for individual kohafields
2467     if( $kohafield =~ /copyrightdate|publicationyear/ ) {
2468         $retval = _adjust_pubyear( $retval );
2469     }
2470
2471     return $retval;
2472 }
2473
2474 =head2 _adjust_pubyear
2475
2476     Helper routine for TransformMarcToKohaOneField
2477
2478 =cut
2479
2480 sub _adjust_pubyear {
2481     my $retval = shift;
2482     # modify return value to keep only the 1st year found
2483     if( $retval =~ m/c(\d\d\d\d)/ and $1 > 0 ) { # search cYYYY first
2484         $retval = $1;
2485     } elsif( $retval =~ m/(\d\d\d\d)/ && $1 > 0 ) {
2486         $retval = $1;
2487     } elsif( $retval =~ m/
2488              (?<year>\d)[-]?[.Xx?]{3}
2489             |(?<year>\d{2})[.Xx?]{2}
2490             |(?<year>\d{3})[.Xx?]
2491             |(?<year>\d)[-]{3}\?
2492             |(?<year>\d\d)[-]{2}\?
2493             |(?<year>\d{3})[-]\?
2494     /xms ) { # the form 198-? occurred in Dutch ISBD rules
2495         my $digits = $+{year};
2496         $retval = $digits * ( 10 ** ( 4 - length($digits) ));
2497     }
2498     return $retval;
2499 }
2500
2501 =head2 CountItemsIssued
2502
2503     my $count = CountItemsIssued( $biblionumber );
2504
2505 =cut
2506
2507 sub CountItemsIssued {
2508     my ($biblionumber) = @_;
2509     my $dbh            = C4::Context->dbh;
2510     my $sth            = $dbh->prepare('SELECT COUNT(*) as issuedCount FROM items, issues WHERE items.itemnumber = issues.itemnumber AND items.biblionumber = ?');
2511     $sth->execute($biblionumber);
2512     my $row = $sth->fetchrow_hashref();
2513     return $row->{'issuedCount'};
2514 }
2515
2516 =head2 ModZebra
2517
2518   ModZebra( $biblionumber, $op, $server, $record );
2519
2520 $biblionumber is the biblionumber we want to index
2521
2522 $op is specialUpdate or recordDelete, and is used to know what we want to do
2523
2524 $server is the server that we want to update
2525
2526 $record is the update MARC record if it's available. If it's not supplied
2527 and is needed, it'll be loaded from the database.
2528
2529 =cut
2530
2531 sub ModZebra {
2532 ###Accepts a $server variable thus we can use it for biblios authorities or other zebra dbs
2533     my ( $biblionumber, $op, $server, $record ) = @_;
2534     $debug && warn "ModZebra: update requested for: $biblionumber $op $server\n";
2535     if ( C4::Context->preference('SearchEngine') eq 'Elasticsearch' ) {
2536
2537         # TODO abstract to a standard API that'll work for whatever
2538         require Koha::SearchEngine::Elasticsearch::Indexer;
2539         my $indexer = Koha::SearchEngine::Elasticsearch::Indexer->new(
2540             {
2541                 index => $server eq 'biblioserver'
2542                 ? $Koha::SearchEngine::BIBLIOS_INDEX
2543                 : $Koha::SearchEngine::AUTHORITIES_INDEX
2544             }
2545         );
2546         if ( $op eq 'specialUpdate' ) {
2547             unless ($record) {
2548                 $record = GetMarcBiblio({
2549                     biblionumber => $biblionumber,
2550                     embed_items  => 1 });
2551             }
2552             my $records = [$record];
2553             $indexer->update_index_background( [$biblionumber], [$record] );
2554         }
2555         elsif ( $op eq 'recordDelete' ) {
2556             $indexer->delete_index_background( [$biblionumber] );
2557         }
2558         else {
2559             croak "ModZebra called with unknown operation: $op";
2560         }
2561     }
2562
2563     my $dbh = C4::Context->dbh;
2564
2565     # true ModZebra commented until indexdata fixes zebraDB crashes (it seems they occur on multiple updates
2566     # at the same time
2567     # replaced by a zebraqueue table, that is filled with ModZebra to run.
2568     # the table is emptied by rebuild_zebra.pl script (using the -z switch)
2569     my $check_sql = "SELECT COUNT(*) FROM zebraqueue
2570     WHERE server = ?
2571         AND   biblio_auth_number = ?
2572         AND   operation = ?
2573         AND   done = 0";
2574     my $check_sth = $dbh->prepare_cached($check_sql);
2575     $check_sth->execute( $server, $biblionumber, $op );
2576     my ($count) = $check_sth->fetchrow_array;
2577     $check_sth->finish();
2578     if ( $count == 0 ) {
2579         my $sth = $dbh->prepare("INSERT INTO zebraqueue  (biblio_auth_number,server,operation) VALUES(?,?,?)");
2580         $sth->execute( $biblionumber, $server, $op );
2581         $sth->finish;
2582     }
2583 }
2584
2585
2586 =head2 EmbedItemsInMarcBiblio
2587
2588     EmbedItemsInMarcBiblio({
2589         marc_record  => $marc,
2590         biblionumber => $biblionumber,
2591         item_numbers => $itemnumbers,
2592         opac         => $opac });
2593
2594 Given a MARC::Record object containing a bib record,
2595 modify it to include the items attached to it as 9XX
2596 per the bib's MARC framework.
2597 if $itemnumbers is defined, only specified itemnumbers are embedded.
2598
2599 If $opac is true, then opac-relevant suppressions are included.
2600
2601 If opac filtering will be done, borcat should be passed to properly
2602 override if necessary.
2603
2604 =cut
2605
2606 sub EmbedItemsInMarcBiblio {
2607     my ($params) = @_;
2608     my ($marc, $biblionumber, $itemnumbers, $opac, $borcat);
2609     $marc = $params->{marc_record};
2610     if ( !$marc ) {
2611         carp 'EmbedItemsInMarcBiblio: No MARC record passed';
2612         return;
2613     }
2614     $biblionumber = $params->{biblionumber};
2615     $itemnumbers = $params->{item_numbers};
2616     $opac = $params->{opac};
2617     $borcat = $params->{borcat} // q{};
2618
2619     $itemnumbers = [] unless defined $itemnumbers;
2620
2621     my $frameworkcode = GetFrameworkCode($biblionumber);
2622     _strip_item_fields($marc, $frameworkcode);
2623
2624     # ... and embed the current items
2625     my $dbh = C4::Context->dbh;
2626     my $sth = $dbh->prepare("SELECT itemnumber FROM items WHERE biblionumber = ?");
2627     $sth->execute($biblionumber);
2628     my ( $itemtag, $itemsubfield ) = GetMarcFromKohaField( "items.itemnumber" );
2629
2630     my @item_fields; # Array holding the actual MARC data for items to be included.
2631     my @items;       # Array holding items which are both in the list (sitenumbers)
2632                      # and on this biblionumber
2633
2634     # Flag indicating if there is potential hiding.
2635     my $opachiddenitems = $opac
2636       && ( C4::Context->preference('OpacHiddenItems') !~ /^\s*$/ );
2637
2638     require C4::Items;
2639     while ( my ($itemnumber) = $sth->fetchrow_array ) {
2640         next if @$itemnumbers and not grep { $_ == $itemnumber } @$itemnumbers;
2641         my $item;
2642         if ( $opachiddenitems ) {
2643             $item = Koha::Items->find($itemnumber);
2644             $item = $item ? $item->unblessed : undef;
2645         }
2646         push @items, { itemnumber => $itemnumber, item => $item };
2647     }
2648     my @items2pass = map { $_->{item} } @items;
2649     my @hiddenitems =
2650       $opachiddenitems
2651       ? C4::Items::GetHiddenItemnumbers({
2652             items  => \@items2pass,
2653             borcat => $borcat })
2654       : ();
2655     # Convert to a hash for quick searching
2656     my %hiddenitems = map { $_ => 1 } @hiddenitems;
2657     foreach my $itemnumber ( map { $_->{itemnumber} } @items ) {
2658         next if $hiddenitems{$itemnumber};
2659         my $item_marc = C4::Items::GetMarcItem( $biblionumber, $itemnumber );
2660         push @item_fields, $item_marc->field($itemtag);
2661     }
2662     $marc->append_fields(@item_fields);
2663 }
2664
2665 =head1 INTERNAL FUNCTIONS
2666
2667 =head2 _koha_marc_update_bib_ids
2668
2669
2670   _koha_marc_update_bib_ids($record, $frameworkcode, $biblionumber, $biblioitemnumber);
2671
2672 Internal function to add or update biblionumber and biblioitemnumber to
2673 the MARC XML.
2674
2675 =cut
2676
2677 sub _koha_marc_update_bib_ids {
2678     my ( $record, $frameworkcode, $biblionumber, $biblioitemnumber ) = @_;
2679
2680     my ( $biblio_tag,     $biblio_subfield )     = GetMarcFromKohaField( "biblio.biblionumber" );
2681     die qq{No biblionumber tag for framework "$frameworkcode"} unless $biblio_tag;
2682     my ( $biblioitem_tag, $biblioitem_subfield ) = GetMarcFromKohaField( "biblioitems.biblioitemnumber" );
2683     die qq{No biblioitemnumber tag for framework "$frameworkcode"} unless $biblioitem_tag;
2684
2685     if ( $biblio_tag < 10 ) {
2686         C4::Biblio::UpsertMarcControlField( $record, $biblio_tag, $biblionumber );
2687     } else {
2688         C4::Biblio::UpsertMarcSubfield($record, $biblio_tag, $biblio_subfield, $biblionumber);
2689     }
2690     if ( $biblioitem_tag < 10 ) {
2691         C4::Biblio::UpsertMarcControlField( $record, $biblioitem_tag, $biblioitemnumber );
2692     } else {
2693         C4::Biblio::UpsertMarcSubfield($record, $biblioitem_tag, $biblioitem_subfield, $biblioitemnumber);
2694     }
2695 }
2696
2697 =head2 _koha_marc_update_biblioitem_cn_sort
2698
2699   _koha_marc_update_biblioitem_cn_sort($marc, $biblioitem, $frameworkcode);
2700
2701 Given a MARC bib record and the biblioitem hash, update the
2702 subfield that contains a copy of the value of biblioitems.cn_sort.
2703
2704 =cut
2705
2706 sub _koha_marc_update_biblioitem_cn_sort {
2707     my $marc          = shift;
2708     my $biblioitem    = shift;
2709     my $frameworkcode = shift;
2710
2711     my ( $biblioitem_tag, $biblioitem_subfield ) = GetMarcFromKohaField( "biblioitems.cn_sort" );
2712     return unless $biblioitem_tag;
2713
2714     my ($cn_sort) = GetClassSort( $biblioitem->{'biblioitems.cn_source'}, $biblioitem->{'cn_class'}, $biblioitem->{'cn_item'} );
2715
2716     if ( my $field = $marc->field($biblioitem_tag) ) {
2717         $field->delete_subfield( code => $biblioitem_subfield );
2718         if ( $cn_sort ne '' ) {
2719             $field->add_subfields( $biblioitem_subfield => $cn_sort );
2720         }
2721     } else {
2722
2723         # if we get here, no biblioitem tag is present in the MARC record, so
2724         # we'll create it if $cn_sort is not empty -- this would be
2725         # an odd combination of events, however
2726         if ($cn_sort) {
2727             $marc->insert_grouped_field( MARC::Field->new( $biblioitem_tag, ' ', ' ', $biblioitem_subfield => $cn_sort ) );
2728         }
2729     }
2730 }
2731
2732 =head2 _koha_add_biblio
2733
2734   my ($biblionumber,$error) = _koha_add_biblio($dbh,$biblioitem);
2735
2736 Internal function to add a biblio ($biblio is a hash with the values)
2737
2738 =cut
2739
2740 sub _koha_add_biblio {
2741     my ( $dbh, $biblio, $frameworkcode ) = @_;
2742
2743     my $error;
2744
2745     # set the series flag
2746     unless (defined $biblio->{'serial'}){
2747         $biblio->{'serial'} = 0;
2748         if ( $biblio->{'seriestitle'} ) { $biblio->{'serial'} = 1 }
2749     }
2750
2751     my $query = "INSERT INTO biblio
2752         SET frameworkcode = ?,
2753             author = ?,
2754             title = ?,
2755             subtitle = ?,
2756             medium = ?,
2757             part_number = ?,
2758             part_name = ?,
2759             unititle =?,
2760             notes = ?,
2761             serial = ?,
2762             seriestitle = ?,
2763             copyrightdate = ?,
2764             datecreated=NOW(),
2765             abstract = ?
2766         ";
2767     my $sth = $dbh->prepare($query);
2768     $sth->execute(
2769         $frameworkcode,        $biblio->{'author'},      $biblio->{'title'},       $biblio->{'subtitle'},
2770         $biblio->{'medium'},   $biblio->{'part_number'}, $biblio->{'part_name'},   $biblio->{'unititle'},
2771         $biblio->{'notes'},    $biblio->{'serial'},      $biblio->{'seriestitle'}, $biblio->{'copyrightdate'},
2772         $biblio->{'abstract'}
2773     );
2774
2775     my $biblionumber = $dbh->{'mysql_insertid'};
2776     if ( $dbh->errstr ) {
2777         $error .= "ERROR in _koha_add_biblio $query" . $dbh->errstr;
2778         warn $error;
2779     }
2780
2781     $sth->finish();
2782
2783     #warn "LEAVING _koha_add_biblio: ".$biblionumber."\n";
2784     return ( $biblionumber, $error );
2785 }
2786
2787 =head2 _koha_modify_biblio
2788
2789   my ($biblionumber,$error) == _koha_modify_biblio($dbh,$biblio,$frameworkcode);
2790
2791 Internal function for updating the biblio table
2792
2793 =cut
2794
2795 sub _koha_modify_biblio {
2796     my ( $dbh, $biblio, $frameworkcode ) = @_;
2797     my $error;
2798
2799     my $query = "
2800         UPDATE biblio
2801         SET    frameworkcode = ?,
2802                author = ?,
2803                title = ?,
2804                subtitle = ?,
2805                medium = ?,
2806                part_number = ?,
2807                part_name = ?,
2808                unititle = ?,
2809                notes = ?,
2810                serial = ?,
2811                seriestitle = ?,
2812                copyrightdate = ?,
2813                abstract = ?
2814         WHERE  biblionumber = ?
2815         "
2816       ;
2817     my $sth = $dbh->prepare($query);
2818
2819     $sth->execute(
2820         $frameworkcode,        $biblio->{'author'},      $biblio->{'title'},       $biblio->{'subtitle'},
2821         $biblio->{'medium'},   $biblio->{'part_number'}, $biblio->{'part_name'},   $biblio->{'unititle'},
2822         $biblio->{'notes'},    $biblio->{'serial'},      $biblio->{'seriestitle'}, $biblio->{'copyrightdate'} ? int($biblio->{'copyrightdate'}) : undef,
2823         $biblio->{'abstract'}, $biblio->{'biblionumber'}
2824     ) if $biblio->{'biblionumber'};
2825
2826     if ( $dbh->errstr || !$biblio->{'biblionumber'} ) {
2827         $error .= "ERROR in _koha_modify_biblio $query" . $dbh->errstr;
2828         warn $error;
2829     }
2830     return ( $biblio->{'biblionumber'}, $error );
2831 }
2832
2833 =head2 _koha_modify_biblioitem_nonmarc
2834
2835   my ($biblioitemnumber,$error) = _koha_modify_biblioitem_nonmarc( $dbh, $biblioitem );
2836
2837 =cut
2838
2839 sub _koha_modify_biblioitem_nonmarc {
2840     my ( $dbh, $biblioitem ) = @_;
2841     my $error;
2842
2843     # re-calculate the cn_sort, it may have changed
2844     my ($cn_sort) = GetClassSort( $biblioitem->{'biblioitems.cn_source'}, $biblioitem->{'cn_class'}, $biblioitem->{'cn_item'} );
2845
2846     my $query = "UPDATE biblioitems
2847     SET biblionumber    = ?,
2848         volume          = ?,
2849         number          = ?,
2850         itemtype        = ?,
2851         isbn            = ?,
2852         issn            = ?,
2853         publicationyear = ?,
2854         publishercode   = ?,
2855         volumedate      = ?,
2856         volumedesc      = ?,
2857         collectiontitle = ?,
2858         collectionissn  = ?,
2859         collectionvolume= ?,
2860         editionstatement= ?,
2861         editionresponsibility = ?,
2862         illus           = ?,
2863         pages           = ?,
2864         notes           = ?,
2865         size            = ?,
2866         place           = ?,
2867         lccn            = ?,
2868         url             = ?,
2869         cn_source       = ?,
2870         cn_class        = ?,
2871         cn_item         = ?,
2872         cn_suffix       = ?,
2873         cn_sort         = ?,
2874         totalissues     = ?,
2875         ean             = ?,
2876         agerestriction  = ?
2877         where biblioitemnumber = ?
2878         ";
2879     my $sth = $dbh->prepare($query);
2880     $sth->execute(
2881         $biblioitem->{'biblionumber'},     $biblioitem->{'volume'},           $biblioitem->{'number'},                $biblioitem->{'itemtype'},
2882         $biblioitem->{'isbn'},             $biblioitem->{'issn'},             $biblioitem->{'publicationyear'},       $biblioitem->{'publishercode'},
2883         $biblioitem->{'volumedate'},       $biblioitem->{'volumedesc'},       $biblioitem->{'collectiontitle'},       $biblioitem->{'collectionissn'},
2884         $biblioitem->{'collectionvolume'}, $biblioitem->{'editionstatement'}, $biblioitem->{'editionresponsibility'}, $biblioitem->{'illus'},
2885         $biblioitem->{'pages'},            $biblioitem->{'bnotes'},           $biblioitem->{'size'},                  $biblioitem->{'place'},
2886         $biblioitem->{'lccn'},             $biblioitem->{'url'},              $biblioitem->{'biblioitems.cn_source'}, $biblioitem->{'cn_class'},
2887         $biblioitem->{'cn_item'},          $biblioitem->{'cn_suffix'},        $cn_sort,                               $biblioitem->{'totalissues'},
2888         $biblioitem->{'ean'},              $biblioitem->{'agerestriction'},   $biblioitem->{'biblioitemnumber'}
2889     );
2890     if ( $dbh->errstr ) {
2891         $error .= "ERROR in _koha_modify_biblioitem_nonmarc $query" . $dbh->errstr;
2892         warn $error;
2893     }
2894     return ( $biblioitem->{'biblioitemnumber'}, $error );
2895 }
2896
2897 =head2 _koha_add_biblioitem
2898
2899   my ($biblioitemnumber,$error) = _koha_add_biblioitem( $dbh, $biblioitem );
2900
2901 Internal function to add a biblioitem
2902
2903 =cut
2904
2905 sub _koha_add_biblioitem {
2906     my ( $dbh, $biblioitem ) = @_;
2907     my $error;
2908
2909     my ($cn_sort) = GetClassSort( $biblioitem->{'biblioitems.cn_source'}, $biblioitem->{'cn_class'}, $biblioitem->{'cn_item'} );
2910     my $query = "INSERT INTO biblioitems SET
2911         biblionumber    = ?,
2912         volume          = ?,
2913         number          = ?,
2914         itemtype        = ?,
2915         isbn            = ?,
2916         issn            = ?,
2917         publicationyear = ?,
2918         publishercode   = ?,
2919         volumedate      = ?,
2920         volumedesc      = ?,
2921         collectiontitle = ?,
2922         collectionissn  = ?,
2923         collectionvolume= ?,
2924         editionstatement= ?,
2925         editionresponsibility = ?,
2926         illus           = ?,
2927         pages           = ?,
2928         notes           = ?,
2929         size            = ?,
2930         place           = ?,
2931         lccn            = ?,
2932         url             = ?,
2933         cn_source       = ?,
2934         cn_class        = ?,
2935         cn_item         = ?,
2936         cn_suffix       = ?,
2937         cn_sort         = ?,
2938         totalissues     = ?,
2939         ean             = ?,
2940         agerestriction  = ?
2941         ";
2942     my $sth = $dbh->prepare($query);
2943     $sth->execute(
2944         $biblioitem->{'biblionumber'},     $biblioitem->{'volume'},           $biblioitem->{'number'},                $biblioitem->{'itemtype'},
2945         $biblioitem->{'isbn'},             $biblioitem->{'issn'},             $biblioitem->{'publicationyear'},       $biblioitem->{'publishercode'},
2946         $biblioitem->{'volumedate'},       $biblioitem->{'volumedesc'},       $biblioitem->{'collectiontitle'},       $biblioitem->{'collectionissn'},
2947         $biblioitem->{'collectionvolume'}, $biblioitem->{'editionstatement'}, $biblioitem->{'editionresponsibility'}, $biblioitem->{'illus'},
2948         $biblioitem->{'pages'},            $biblioitem->{'bnotes'},           $biblioitem->{'size'},                  $biblioitem->{'place'},
2949         $biblioitem->{'lccn'},             $biblioitem->{'url'},                   $biblioitem->{'biblioitems.cn_source'},
2950         $biblioitem->{'cn_class'},         $biblioitem->{'cn_item'},          $biblioitem->{'cn_suffix'},             $cn_sort,
2951         $biblioitem->{'totalissues'},      $biblioitem->{'ean'},              $biblioitem->{'agerestriction'}
2952     );
2953     my $bibitemnum = $dbh->{'mysql_insertid'};
2954
2955     if ( $dbh->errstr ) {
2956         $error .= "ERROR in _koha_add_biblioitem $query" . $dbh->errstr;
2957         warn $error;
2958     }
2959     $sth->finish();
2960     return ( $bibitemnum, $error );
2961 }
2962
2963 =head2 _koha_delete_biblio
2964
2965   $error = _koha_delete_biblio($dbh,$biblionumber);
2966
2967 Internal sub for deleting from biblio table -- also saves to deletedbiblio
2968
2969 C<$dbh> - the database handle
2970
2971 C<$biblionumber> - the biblionumber of the biblio to be deleted
2972
2973 =cut
2974
2975 # FIXME: add error handling
2976
2977 sub _koha_delete_biblio {
2978     my ( $dbh, $biblionumber ) = @_;
2979
2980     # get all the data for this biblio
2981     my $sth = $dbh->prepare("SELECT * FROM biblio WHERE biblionumber=?");
2982     $sth->execute($biblionumber);
2983
2984     # FIXME There is a transaction in _koha_delete_biblio_metadata
2985     # But actually all the following should be done inside a single transaction
2986     if ( my $data = $sth->fetchrow_hashref ) {
2987
2988         # save the record in deletedbiblio
2989         # find the fields to save
2990         my $query = "INSERT INTO deletedbiblio SET ";
2991         my @bind  = ();
2992         foreach my $temp ( keys %$data ) {
2993             $query .= "$temp = ?,";
2994             push( @bind, $data->{$temp} );
2995         }
2996
2997         # replace the last , by ",?)"
2998         $query =~ s/\,$//;
2999         my $bkup_sth = $dbh->prepare($query);
3000         $bkup_sth->execute(@bind);
3001         $bkup_sth->finish;
3002
3003         _koha_delete_biblio_metadata( $biblionumber );
3004
3005         # delete the biblio
3006         my $sth2 = $dbh->prepare("DELETE FROM biblio WHERE biblionumber=?");
3007         $sth2->execute($biblionumber);
3008         # update the timestamp (Bugzilla 7146)
3009         $sth2= $dbh->prepare("UPDATE deletedbiblio SET timestamp=NOW() WHERE biblionumber=?");
3010         $sth2->execute($biblionumber);
3011         $sth2->finish;
3012     }
3013     $sth->finish;
3014     return;
3015 }
3016
3017 =head2 _koha_delete_biblioitems
3018
3019   $error = _koha_delete_biblioitems($dbh,$biblioitemnumber);
3020
3021 Internal sub for deleting from biblioitems table -- also saves to deletedbiblioitems
3022
3023 C<$dbh> - the database handle
3024 C<$biblionumber> - the biblioitemnumber of the biblioitem to be deleted
3025
3026 =cut
3027
3028 # FIXME: add error handling
3029
3030 sub _koha_delete_biblioitems {
3031     my ( $dbh, $biblioitemnumber ) = @_;
3032
3033     # get all the data for this biblioitem
3034     my $sth = $dbh->prepare("SELECT * FROM biblioitems WHERE biblioitemnumber=?");
3035     $sth->execute($biblioitemnumber);
3036
3037     if ( my $data = $sth->fetchrow_hashref ) {
3038
3039         # save the record in deletedbiblioitems
3040         # find the fields to save
3041         my $query = "INSERT INTO deletedbiblioitems SET ";
3042         my @bind  = ();
3043         foreach my $temp ( keys %$data ) {
3044             $query .= "$temp = ?,";
3045             push( @bind, $data->{$temp} );
3046         }
3047
3048         # replace the last , by ",?)"
3049         $query =~ s/\,$//;
3050         my $bkup_sth = $dbh->prepare($query);
3051         $bkup_sth->execute(@bind);
3052         $bkup_sth->finish;
3053
3054         # delete the biblioitem
3055         my $sth2 = $dbh->prepare("DELETE FROM biblioitems WHERE biblioitemnumber=?");
3056         $sth2->execute($biblioitemnumber);
3057         # update the timestamp (Bugzilla 7146)
3058         $sth2= $dbh->prepare("UPDATE deletedbiblioitems SET timestamp=NOW() WHERE biblioitemnumber=?");
3059         $sth2->execute($biblioitemnumber);
3060         $sth2->finish;
3061     }
3062     $sth->finish;
3063     return;
3064 }
3065
3066 =head2 _koha_delete_biblio_metadata
3067
3068   $error = _koha_delete_biblio_metadata($biblionumber);
3069
3070 C<$biblionumber> - the biblionumber of the biblio metadata to be deleted
3071
3072 =cut
3073
3074 sub _koha_delete_biblio_metadata {
3075     my ($biblionumber) = @_;
3076
3077     my $dbh    = C4::Context->dbh;
3078     my $schema = Koha::Database->new->schema;
3079     $schema->txn_do(
3080         sub {
3081             $dbh->do( q|
3082                 INSERT INTO deletedbiblio_metadata (biblionumber, format, `schema`, metadata)
3083                 SELECT biblionumber, format, `schema`, metadata FROM biblio_metadata WHERE biblionumber=?
3084             |,  undef, $biblionumber );
3085             $dbh->do( q|DELETE FROM biblio_metadata WHERE biblionumber=?|,
3086                 undef, $biblionumber );
3087         }
3088     );
3089 }
3090
3091 =head1 UNEXPORTED FUNCTIONS
3092
3093 =head2 ModBiblioMarc
3094
3095   &ModBiblioMarc($newrec,$biblionumber,$frameworkcode);
3096
3097 Add MARC XML data for a biblio to koha
3098
3099 Function exported, but should NOT be used, unless you really know what you're doing
3100
3101 =cut
3102
3103 sub ModBiblioMarc {
3104     # pass the MARC::Record to this function, and it will create the records in
3105     # the marcxml field
3106     my ( $record, $biblionumber, $frameworkcode ) = @_;
3107     if ( !$record ) {
3108         carp 'ModBiblioMarc passed an undefined record';
3109         return;
3110     }
3111
3112     # Clone record as it gets modified
3113     $record = $record->clone();
3114     my $dbh    = C4::Context->dbh;
3115     my @fields = $record->fields();
3116     if ( !$frameworkcode ) {
3117         $frameworkcode = "";
3118     }
3119     my $sth = $dbh->prepare("UPDATE biblio SET frameworkcode=? WHERE biblionumber=?");
3120     $sth->execute( $frameworkcode, $biblionumber );
3121     $sth->finish;
3122     my $encoding = C4::Context->preference("marcflavour");
3123
3124     # deal with UNIMARC field 100 (encoding) : create it if needed & set encoding to unicode
3125     if ( $encoding eq "UNIMARC" ) {
3126         my $defaultlanguage = C4::Context->preference("UNIMARCField100Language");
3127         $defaultlanguage = "fre" if (!$defaultlanguage || length($defaultlanguage) != 3);
3128         my $string = $record->subfield( 100, "a" );
3129         if ( ($string) && ( length( $record->subfield( 100, "a" ) ) == 36 ) ) {
3130             my $f100 = $record->field(100);
3131             $record->delete_field($f100);
3132         } else {
3133             $string = POSIX::strftime( "%Y%m%d", localtime );
3134             $string =~ s/\-//g;
3135             $string = sprintf( "%-*s", 35, $string );
3136             substr ( $string, 22, 3, $defaultlanguage);
3137         }
3138         substr( $string, 25, 3, "y50" );
3139         unless ( $record->subfield( 100, "a" ) ) {
3140             $record->insert_fields_ordered( MARC::Field->new( 100, "", "", "a" => $string ) );
3141         }
3142     }
3143
3144     #enhancement 5374: update transaction date (005) for marc21/unimarc
3145     if($encoding =~ /MARC21|UNIMARC/) {
3146       my @a= (localtime) [5,4,3,2,1,0]; $a[0]+=1900; $a[1]++;
3147         # YY MM DD HH MM SS (update year and month)
3148       my $f005= $record->field('005');
3149       $f005->update(sprintf("%4d%02d%02d%02d%02d%04.1f",@a)) if $f005;
3150     }
3151
3152     my $metadata = {
3153         biblionumber => $biblionumber,
3154         format       => 'marcxml',
3155         schema       => C4::Context->preference('marcflavour'),
3156     };
3157     $record->as_usmarc; # Bug 20126/10455 This triggers field length calculation
3158
3159     my $m_rs = Koha::Biblio::Metadatas->find($metadata) //
3160         Koha::Biblio::Metadata->new($metadata);
3161
3162     my $userenv = C4::Context->userenv;
3163     if ($userenv) {
3164         my $borrowernumber = $userenv->{number};
3165         my $borrowername = join ' ', map { $_ // q{} } @$userenv{qw(firstname surname)};
3166         unless ($m_rs->in_storage) {
3167             Koha::Util::MARC::set_marc_field($record, C4::Context->preference('MarcFieldForCreatorId'), $borrowernumber);
3168             Koha::Util::MARC::set_marc_field($record, C4::Context->preference('MarcFieldForCreatorName'), $borrowername);
3169         }
3170         Koha::Util::MARC::set_marc_field($record, C4::Context->preference('MarcFieldForModifierId'), $borrowernumber);
3171         Koha::Util::MARC::set_marc_field($record, C4::Context->preference('MarcFieldForModifierName'), $borrowername);
3172     }
3173
3174     $m_rs->metadata( $record->as_xml_record($encoding) );
3175     $m_rs->store;
3176
3177     ModZebra( $biblionumber, "specialUpdate", "biblioserver" );
3178
3179     return $biblionumber;
3180 }
3181
3182 =head2 prepare_host_field
3183
3184 $marcfield = prepare_host_field( $hostbiblioitem, $marcflavour );
3185 Generate the host item entry for an analytic child entry
3186
3187 =cut
3188
3189 sub prepare_host_field {
3190     my ( $hostbiblio, $marcflavour ) = @_;
3191     $marcflavour ||= C4::Context->preference('marcflavour');
3192     my $host = GetMarcBiblio({ biblionumber => $hostbiblio });
3193     # unfortunately as_string does not 'do the right thing'
3194     # if field returns undef
3195     my %sfd;
3196     my $field;
3197     my $host_field;
3198     if ( $marcflavour eq 'MARC21' || $marcflavour eq 'NORMARC' ) {
3199         if ( $field = $host->field('100') || $host->field('110') || $host->field('11') ) {
3200             my $s = $field->as_string('ab');
3201             if ($s) {
3202                 $sfd{a} = $s;
3203             }
3204         }
3205         if ( $field = $host->field('245') ) {
3206             my $s = $field->as_string('a');
3207             if ($s) {
3208                 $sfd{t} = $s;
3209             }
3210         }
3211         if ( $field = $host->field('260') ) {
3212             my $s = $field->as_string('abc');
3213             if ($s) {
3214                 $sfd{d} = $s;
3215             }
3216         }
3217         if ( $field = $host->field('240') ) {
3218             my $s = $field->as_string();
3219             if ($s) {
3220                 $sfd{b} = $s;
3221             }
3222         }
3223         if ( $field = $host->field('022') ) {
3224             my $s = $field->as_string('a');
3225             if ($s) {
3226                 $sfd{x} = $s;
3227             }
3228         }
3229         if ( $field = $host->field('020') ) {
3230             my $s = $field->as_string('a');
3231             if ($s) {
3232                 $sfd{z} = $s;
3233             }
3234         }
3235         if ( $field = $host->field('001') ) {
3236             $sfd{w} = $field->data(),;
3237         }
3238         $host_field = MARC::Field->new( 773, '0', ' ', %sfd );
3239         return $host_field;
3240     }
3241     elsif ( $marcflavour eq 'UNIMARC' ) {
3242         #author
3243         if ( $field = $host->field('700') || $host->field('710') || $host->field('720') ) {
3244             my $s = $field->as_string('ab');
3245             if ($s) {
3246                 $sfd{a} = $s;
3247             }
3248         }
3249         #title
3250         if ( $field = $host->field('200') ) {
3251             my $s = $field->as_string('a');
3252             if ($s) {
3253                 $sfd{t} = $s;
3254             }
3255         }
3256         #place of publicaton
3257         if ( $field = $host->field('210') ) {
3258             my $s = $field->as_string('a');
3259             if ($s) {
3260                 $sfd{c} = $s;
3261             }
3262         }
3263         #date of publication
3264         if ( $field = $host->field('210') ) {
3265             my $s = $field->as_string('d');
3266             if ($s) {
3267                 $sfd{d} = $s;
3268             }
3269         }
3270         #edition statement
3271         if ( $field = $host->field('205') ) {
3272             my $s = $field->as_string();
3273             if ($s) {
3274                 $sfd{e} = $s;
3275             }
3276         }
3277         #URL
3278         if ( $field = $host->field('856') ) {
3279             my $s = $field->as_string('u');
3280             if ($s) {
3281                 $sfd{u} = $s;
3282             }
3283         }
3284         #ISSN
3285         if ( $field = $host->field('011') ) {
3286             my $s = $field->as_string('a');
3287             if ($s) {
3288                 $sfd{x} = $s;
3289             }
3290         }
3291         #ISBN
3292         if ( $field = $host->field('010') ) {
3293             my $s = $field->as_string('a');
3294             if ($s) {
3295                 $sfd{y} = $s;
3296             }
3297         }
3298         if ( $field = $host->field('001') ) {
3299             $sfd{0} = $field->data(),;
3300         }
3301         $host_field = MARC::Field->new( 461, '0', ' ', %sfd );
3302         return $host_field;
3303     }
3304     return;
3305 }
3306
3307
3308 =head2 UpdateTotalIssues
3309
3310   UpdateTotalIssues($biblionumber, $increase, [$value])
3311
3312 Update the total issue count for a particular bib record.
3313
3314 =over 4
3315
3316 =item C<$biblionumber> is the biblionumber of the bib to update
3317
3318 =item C<$increase> is the amount to increase (or decrease) the total issues count by
3319
3320 =item C<$value> is the absolute value that total issues count should be set to. If provided, C<$increase> is ignored.
3321
3322 =back
3323
3324 =cut
3325
3326 sub UpdateTotalIssues {
3327     my ($biblionumber, $increase, $value) = @_;
3328     my $totalissues;
3329
3330     my $record = GetMarcBiblio({ biblionumber => $biblionumber });
3331     unless ($record) {
3332         carp "UpdateTotalIssues could not get biblio record";
3333         return;
3334     }
3335     my $biblio = Koha::Biblios->find( $biblionumber );
3336     unless ($biblio) {
3337         carp "UpdateTotalIssues could not get datas of biblio";
3338         return;
3339     }
3340     my $biblioitem = $biblio->biblioitem;
3341     my ($totalissuestag, $totalissuessubfield) = GetMarcFromKohaField( 'biblioitems.totalissues' );
3342     unless ($totalissuestag) {
3343         return 1; # There is nothing to do
3344     }
3345
3346     if (defined $value) {
3347         $totalissues = $value;
3348     } else {
3349         $totalissues = $biblioitem->totalissues + $increase;
3350     }
3351
3352      my $field = $record->field($totalissuestag);
3353      if (defined $field) {
3354          $field->update( $totalissuessubfield => $totalissues );
3355      } else {
3356          $field = MARC::Field->new($totalissuestag, '0', '0',
3357                  $totalissuessubfield => $totalissues);
3358          $record->insert_grouped_field($field);
3359      }
3360
3361      return ModBiblio($record, $biblionumber, $biblio->frameworkcode);
3362 }
3363
3364 =head2 RemoveAllNsb
3365
3366     &RemoveAllNsb($record);
3367
3368 Removes all nsb/nse chars from a record
3369
3370 =cut
3371
3372 sub RemoveAllNsb {
3373     my $record = shift;
3374     if (!$record) {
3375         carp 'RemoveAllNsb called with undefined record';
3376         return;
3377     }
3378
3379     SetUTF8Flag($record);
3380
3381     foreach my $field ($record->fields()) {
3382         if ($field->is_control_field()) {
3383             $field->update(nsb_clean($field->data()));
3384         } else {
3385             my @subfields = $field->subfields();
3386             my @new_subfields;
3387             foreach my $subfield (@subfields) {
3388                 push @new_subfields, $subfield->[0] => nsb_clean($subfield->[1]);
3389             }
3390             if (scalar(@new_subfields) > 0) {
3391                 my $new_field;
3392                 eval {
3393                     $new_field = MARC::Field->new(
3394                         $field->tag(),
3395                         $field->indicator(1),
3396                         $field->indicator(2),
3397                         @new_subfields
3398                     );
3399                 };
3400                 if ($@) {
3401                     warn "error in RemoveAllNsb : $@";
3402                 } else {
3403                     $field->replace_with($new_field);
3404                 }
3405             }
3406         }
3407     }
3408
3409     return $record;
3410 }
3411
3412 1;
3413
3414
3415 =head2 _after_biblio_action_hooks
3416
3417 Helper method that takes care of calling all plugin hooks
3418
3419 =cut
3420
3421 sub _after_biblio_action_hooks {
3422     my ( $args ) = @_;
3423
3424     my $biblio_id = $args->{biblio_id};
3425     my $action    = $args->{action};
3426
3427     if ( C4::Context->preference('UseKohaPlugins') && C4::Context->config("enable_plugins") ) {
3428
3429         my @plugins = Koha::Plugins->new->GetPlugins({
3430             method => 'after_biblio_action',
3431         });
3432
3433         if (@plugins) {
3434
3435             my $biblio = Koha::Biblios->find( $biblio_id );
3436
3437             foreach my $plugin ( @plugins ) {
3438                 try {
3439                     $plugin->after_biblio_action({ action => $action, biblio => $biblio, biblio_id => $biblio_id });
3440                 }
3441                 catch {
3442                     warn "$_";
3443                 };
3444             }
3445         }
3446     }
3447 }
3448
3449 __END__
3450
3451 =head1 AUTHOR
3452
3453 Koha Development Team <http://koha-community.org/>
3454
3455 Paul POULAIN paul.poulain@free.fr
3456
3457 Joshua Ferraro jmf@liblime.com
3458
3459 =cut