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         GetMarcUrls
  42         GetUsedMarcStructure
  43         GetXmlBiblio
  44         GetMarcPrice
  45         MungeMarcPrice
  46         GetMarcQuantity
  47         GetAuthorisedValueDesc
  48         GetMarcStructure
  49         IsMarcStructureInternal
  50         GetMarcFromKohaField
  51         GetMarcSubfieldStructureFromKohaField
  52         GetFrameworkCode
  53         TransformKohaToMarc
  54         PrepHostMarcField
  55         CountItemsIssued
  56         ModBiblio
  57         ModZebra
  58         UpdateTotalIssues
  59         RemoveAllNsb
  60         DelBiblio
  61         BiblioAutoLink
  62         LinkBibHeadingsToAuthorities
  63         TransformMarcToKoha
  64         TransformHtmlToMarc
  65         TransformHtmlToXml
  66         prepare_host_field
  67     );
  68
  69     # Internal functions
  70     # those functions are exported but should not be used
  71     # they are useful in a few circumstances, so they are exported,
  72     # but don't use them unless you are a core developer ;-)
  73     push @EXPORT, qw(
  74       ModBiblioMarc
  75     );
  76 }
  77
  78 use Carp;
  79 use Try::Tiny;
  80
  81 use Encode qw( decode is_utf8 );
  82 use List::MoreUtils qw( uniq );
  83 use MARC::Record;
  84 use MARC::File::USMARC;
  85 use MARC::File::XML;
  86 use POSIX qw(strftime);
  87 use Module::Load::Conditional qw(can_load);
  88
  89 use C4::Koha;
  90 use C4::Log;    # logaction
  91 use C4::Budgets;
  92 use C4::ClassSource;
  93 use C4::Charset;
  94 use C4::Linker;
  95 use C4::OAI::Sets;
  96 use C4::Debug;
  97
  98 use Koha::Caches;
  99 use Koha::Authority::Types;
 100 use Koha::Acquisition::Currencies;
 101 use Koha::Biblio::Metadatas;
 102 use Koha::Holds;
 103 use Koha::ItemTypes;
 104 use Koha::Plugins;
 105 use Koha::SearchEngine;
 106 use Koha::Libraries;
 107 use Koha::Util::MARC;
 108
 109 use vars qw($debug $cgi_debug);
 110
 111
 112 =head1 NAME
 113
 114 C4::Biblio - cataloging management functions
 115
 116 =head1 DESCRIPTION
 117
 118 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:
 119
 120 =over 4
 121
 122 =item 1. in the biblio,biblioitems,items, etc tables, which are limited to a one-to-one mapping to underlying MARC data
 123
 124 =item 2. as raw MARC in the Zebra index and storage engine
 125
 126 =item 3. as MARC XML in biblio_metadata.metadata
 127
 128 =back
 129
 130 In the 3.0 version of Koha, the authoritative record-level information is in biblio_metadata.metadata
 131
 132 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.
 133
 134 =over 4
 135
 136 =item 1. Compared with MySQL, Zebra is slow to update an index for small data changes -- especially for proc-intensive operations like circulation
 137
 138 =item 2. Zebra's index has been known to crash and a backup of the data is necessary to rebuild it in such cases
 139
 140 =back
 141
 142 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:
 143
 144 =over 4
 145
 146 =item 1. Add*/Mod*/Del*/ - high-level external functions suitable for being called from external scripts to manage the collection
 147
 148 =item 2. _koha_* - low-level internal functions for managing the koha tables
 149
 150 =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.
 151
 152 =item 4. Zebra functions used to update the Zebra index
 153
 154 =item 5. internal helper functions such as char_decode, checkitems, etc. Some of these probably belong in Koha.pm
 155
 156 =back
 157
 158 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 :
 159
 160 =over 4
 161
 162 =item 1. save datas in biblio and biblioitems table, that gives us a biblionumber and a biblioitemnumber
 163
 164 =item 2. add the biblionumber and biblioitemnumber into the MARC records
 165
 166 =item 3. save the marc record
 167
 168 =back
 169
 170 =head1 EXPORTED FUNCTIONS
 171
 172 =head2 AddBiblio
 173
 174   ($biblionumber,$biblioitemnumber) = AddBiblio($record,$frameworkcode);
 175
 176 Exported function (core API) for adding a new biblio to koha.
 177
 178 The first argument is a C<MARC::Record> object containing the
 179 bib to add, while the second argument is the desired MARC
 180 framework code.
 181
 182 This function also accepts a third, optional argument: a hashref
 183 to additional options.  The only defined option is C<defer_marc_save>,
 184 which if present and mapped to a true value, causes C<AddBiblio>
 185 to omit the call to save the MARC in C<biblio_metadata.metadata>
 186 This option is provided B<only>
 187 for the use of scripts such as C<bulkmarcimport.pl> that may need
 188 to do some manipulation of the MARC record for item parsing before
 189 saving it and which cannot afford the performance hit of saving
 190 the MARC record twice.  Consequently, do not use that option
 191 unless you can guarantee that C<ModBiblioMarc> will be called.
 192
 193 =cut
 194
 195 sub AddBiblio {
 196     my $record          = shift;
 197     my $frameworkcode   = shift;
 198     my $options         = @_ ? shift : undef;
 199     my $defer_marc_save = 0;
 200     if (!$record) {
 201         carp('AddBiblio called with undefined record');
 202         return;
 203     }
 204     if ( defined $options and exists $options->{'defer_marc_save'} and $options->{'defer_marc_save'} ) {
 205         $defer_marc_save = 1;
 206     }
 207
 208     if (C4::Context->preference('BiblioAddsAuthorities')) {
 209         BiblioAutoLink( $record, $frameworkcode );
 210     }
 211
 212     my ( $biblionumber, $biblioitemnumber, $error );
 213     my $dbh = C4::Context->dbh;
 214
 215     # transform the data into koha-table style data
 216     SetUTF8Flag($record);
 217     my $olddata = TransformMarcToKoha( $record, $frameworkcode );
 218     ( $biblionumber, $error ) = _koha_add_biblio( $dbh, $olddata, $frameworkcode );
 219     $olddata->{'biblionumber'} = $biblionumber;
 220     ( $biblioitemnumber, $error ) = _koha_add_biblioitem( $dbh, $olddata );
 221
 222     _koha_marc_update_bib_ids( $record, $frameworkcode, $biblionumber, $biblioitemnumber );
 223
 224     # update MARC subfield that stores biblioitems.cn_sort
 225     _koha_marc_update_biblioitem_cn_sort( $record, $olddata, $frameworkcode );
 226
 227     # now add the record
 228     ModBiblioMarc( $record, $biblionumber, $frameworkcode ) unless $defer_marc_save;
 229
 230     # update OAI-PMH sets
 231     if(C4::Context->preference("OAI-PMH:AutoUpdateSets")) {
 232         C4::OAI::Sets::UpdateOAISetsBiblio($biblionumber, $record);
 233     }
 234
 235     _after_biblio_action_hooks({ action => 'create', biblio_id => $biblionumber });
 236
 237     logaction( "CATALOGUING", "ADD", $biblionumber, "biblio" ) if C4::Context->preference("CataloguingLog");
 238     return ( $biblionumber, $biblioitemnumber );
 239 }
 240
 241 =head2 ModBiblio
 242
 243   ModBiblio( $record,$biblionumber,$frameworkcode, $disable_autolink);
 244
 245 Replace an existing bib record identified by C<$biblionumber>
 246 with one supplied by the MARC::Record object C<$record>.  The embedded
 247 item, biblioitem, and biblionumber fields from the previous
 248 version of the bib record replace any such fields of those tags that
 249 are present in C<$record>.  Consequently, ModBiblio() is not
 250 to be used to try to modify item records.
 251
 252 C<$frameworkcode> specifies the MARC framework to use
 253 when storing the modified bib record; among other things,
 254 this controls how MARC fields get mapped to display columns
 255 in the C<biblio> and C<biblioitems> tables, as well as
 256 which fields are used to store embedded item, biblioitem,
 257 and biblionumber data for indexing.
 258
 259 Unless C<$disable_autolink> is passed ModBiblio will relink record headings
 260 to authorities based on settings in the system preferences. This flag allows
 261 us to not relink records when the authority linker is saving modifications.
 262
 263 Returns 1 on success 0 on failure
 264
 265 =cut
 266
 267 sub ModBiblio {
 268     my ( $record, $biblionumber, $frameworkcode, $disable_autolink ) = @_;
 269     if (!$record) {
 270         carp 'No record passed to ModBiblio';
 271         return 0;
 272     }
 273
 274     if ( C4::Context->preference("CataloguingLog") ) {
 275         my $newrecord = GetMarcBiblio({ biblionumber => $biblionumber });
 276         logaction( "CATALOGUING", "MODIFY", $biblionumber, "biblio BEFORE=>" . $newrecord->as_formatted );
 277     }
 278
 279     if ( !$disable_autolink && C4::Context->preference('BiblioAddsAuthorities') ) {
 280         BiblioAutoLink( $record, $frameworkcode );
 281     }
 282
 283     # Cleaning up invalid fields must be done early or SetUTF8Flag is liable to
 284     # throw an exception which probably won't be handled.
 285     foreach my $field ($record->fields()) {
 286         if (! $field->is_control_field()) {
 287             if (scalar($field->subfields()) == 0 || (scalar($field->subfields()) == 1 && $field->subfield('9'))) {
 288                 $record->delete_field($field);
 289             }
 290         }
 291     }
 292
 293     SetUTF8Flag($record);
 294     my $dbh = C4::Context->dbh;
 295
 296     $frameworkcode = "" if !$frameworkcode || $frameworkcode eq "Default"; # XXX
 297
 298     _strip_item_fields($record, $frameworkcode);
 299
 300     # update biblionumber and biblioitemnumber in MARC
 301     # FIXME - this is assuming a 1 to 1 relationship between
 302     # biblios and biblioitems
 303     my $sth = $dbh->prepare("select biblioitemnumber from biblioitems where biblionumber=?");
 304     $sth->execute($biblionumber);
 305     my ($biblioitemnumber) = $sth->fetchrow;
 306     $sth->finish();
 307     _koha_marc_update_bib_ids( $record, $frameworkcode, $biblionumber, $biblioitemnumber );
 308
 309     # load the koha-table data object
 310     my $oldbiblio = TransformMarcToKoha( $record, $frameworkcode );
 311
 312     # update MARC subfield that stores biblioitems.cn_sort
 313     _koha_marc_update_biblioitem_cn_sort( $record, $oldbiblio, $frameworkcode );
 314
 315     # update the MARC record (that now contains biblio and items) with the new record data
 316     &ModBiblioMarc( $record, $biblionumber, $frameworkcode );
 317
 318     # modify the other koha tables
 319     _koha_modify_biblio( $dbh, $oldbiblio, $frameworkcode );
 320     _koha_modify_biblioitem_nonmarc( $dbh, $oldbiblio );
 321
 322     _after_biblio_action_hooks({ action => 'modify', biblio_id => $biblionumber });
 323
 324     # update OAI-PMH sets
 325     if(C4::Context->preference("OAI-PMH:AutoUpdateSets")) {
 326         C4::OAI::Sets::UpdateOAISetsBiblio($biblionumber, $record);
 327     }
 328
 329     return 1;
 330 }
 331
 332 =head2 _strip_item_fields
 333
 334   _strip_item_fields($record, $frameworkcode)
 335
 336 Utility routine to remove item tags from a
 337 MARC bib.
 338
 339 =cut
 340
 341 sub _strip_item_fields {
 342     my $record = shift;
 343     my $frameworkcode = shift;
 344     # get the items before and append them to the biblio before updating the record, atm we just have the biblio
 345     my ( $itemtag, $itemsubfield ) = GetMarcFromKohaField( "items.itemnumber" );
 346
 347     # delete any item fields from incoming record to avoid
 348     # duplication or incorrect data - use AddItem() or ModItem()
 349     # to change items
 350     foreach my $field ( $record->field($itemtag) ) {
 351         $record->delete_field($field);
 352     }
 353 }
 354
 355 =head2 DelBiblio
 356
 357   my $error = &DelBiblio($biblionumber);
 358
 359 Exported function (core API) for deleting a biblio in koha.
 360 Deletes biblio record from Zebra and Koha tables (biblio & biblioitems)
 361 Also backs it up to deleted* tables.
 362 Checks to make sure that the biblio has no items attached.
 363 return:
 364 C<$error> : undef unless an error occurs
 365
 366 =cut
 367
 368 sub DelBiblio {
 369     my ($biblionumber) = @_;
 370
 371     my $biblio = Koha::Biblios->find( $biblionumber );
 372     return unless $biblio; # Should we throw an exception instead?
 373
 374     my $dbh = C4::Context->dbh;
 375     my $error;    # for error handling
 376
 377     # First make sure this biblio has no items attached
 378     my $sth = $dbh->prepare("SELECT itemnumber FROM items WHERE biblionumber=?");
 379     $sth->execute($biblionumber);
 380     if ( my $itemnumber = $sth->fetchrow ) {
 381
 382         # Fix this to use a status the template can understand
 383         $error .= "This Biblio has items attached, please delete them first before deleting this biblio ";
 384     }
 385
 386     return $error if $error;
 387
 388     # We delete any existing holds
 389     my $holds = $biblio->holds;
 390     while ( my $hold = $holds->next ) {
 391         $hold->cancel;
 392     }
 393
 394     # Delete in Zebra. Be careful NOT to move this line after _koha_delete_biblio
 395     # for at least 2 reasons :
 396     # - if something goes wrong, the biblio may be deleted from Koha but not from zebra
 397     #   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)
 398     ModZebra( $biblionumber, "recordDelete", "biblioserver" );
 399
 400     # delete biblioitems and items from Koha tables and save in deletedbiblioitems,deleteditems
 401     $sth = $dbh->prepare("SELECT biblioitemnumber FROM biblioitems WHERE biblionumber=?");
 402     $sth->execute($biblionumber);
 403     while ( my $biblioitemnumber = $sth->fetchrow ) {
 404
 405         # delete this biblioitem
 406         $error = _koha_delete_biblioitems( $dbh, $biblioitemnumber );
 407         return $error if $error;
 408     }
 409
 410
 411     # delete biblio from Koha tables and save in deletedbiblio
 412     # must do this *after* _koha_delete_biblioitems, otherwise
 413     # delete cascade will prevent deletedbiblioitems rows
 414     # from being generated by _koha_delete_biblioitems
 415     $error = _koha_delete_biblio( $dbh, $biblionumber );
 416
 417     _after_biblio_action_hooks({ action => 'delete', biblio_id => $biblionumber });
 418
 419     logaction( "CATALOGUING", "DELETE", $biblionumber, "biblio" ) if C4::Context->preference("CataloguingLog");
 420
 421     return;
 422 }
 423
 424
 425 =head2 BiblioAutoLink
 426
 427   my $headings_linked = BiblioAutoLink($record, $frameworkcode)
 428
 429 Automatically links headings in a bib record to authorities.
 430
 431 Returns the number of headings changed
 432
 433 =cut
 434
 435 sub BiblioAutoLink {
 436     my $record        = shift;
 437     my $frameworkcode = shift;
 438     if (!$record) {
 439         carp('Undefined record passed to BiblioAutoLink');
 440         return 0;
 441     }
 442     my ( $num_headings_changed, %results );
 443
 444     my $linker_module =
 445       "C4::Linker::" . ( C4::Context->preference("LinkerModule") || 'Default' );
 446     unless ( can_load( modules => { $linker_module => undef } ) ) {
 447         $linker_module = 'C4::Linker::Default';
 448         unless ( can_load( modules => { $linker_module => undef } ) ) {
 449             return 0;
 450         }
 451     }
 452
 453     my $linker = $linker_module->new(
 454         { 'options' => C4::Context->preference("LinkerOptions") } );
 455     my ( $headings_changed, undef ) =
 456       LinkBibHeadingsToAuthorities( $linker, $record, $frameworkcode, C4::Context->preference("CatalogModuleRelink") || '' );
 457     # By default we probably don't want to relink things when cataloging
 458     return $headings_changed;
 459 }
 460
 461 =head2 LinkBibHeadingsToAuthorities
 462
 463   my $num_headings_changed, %results = LinkBibHeadingsToAuthorities($linker, $marc, $frameworkcode, [$allowrelink]);
 464
 465 Links bib headings to authority records by checking
 466 each authority-controlled field in the C<MARC::Record>
 467 object C<$marc>, looking for a matching authority record,
 468 and setting the linking subfield $9 to the ID of that
 469 authority record.
 470
 471 If $allowrelink is false, existing authids will never be
 472 replaced, regardless of the values of LinkerKeepStale and
 473 LinkerRelink.
 474
 475 Returns the number of heading links changed in the
 476 MARC record.
 477
 478 =cut
 479
 480 sub LinkBibHeadingsToAuthorities {
 481     my $linker        = shift;
 482     my $bib           = shift;
 483     my $frameworkcode = shift;
 484     my $allowrelink = shift;
 485     my %results;
 486     if (!$bib) {
 487         carp 'LinkBibHeadingsToAuthorities called on undefined bib record';
 488         return ( 0, {});
 489     }
 490     require C4::Heading;
 491     require C4::AuthoritiesMarc;
 492
 493     $allowrelink = 1 unless defined $allowrelink;
 494     my $num_headings_changed = 0;
 495     foreach my $field ( $bib->fields() ) {
 496         my $heading = C4::Heading->new_from_field( $field, $frameworkcode );
 497         next unless defined $heading;
 498
 499         # check existing $9
 500         my $current_link = $field->subfield('9');
 501
 502         if ( defined $current_link && (!$allowrelink || !C4::Context->preference('LinkerRelink')) )
 503         {
 504             $results{'linked'}->{ $heading->display_form() }++;
 505             next;
 506         }
 507
 508         my ( $authid, $fuzzy, $match_count ) = $linker->get_link($heading);
 509         if ($authid) {
 510             $results{ $fuzzy ? 'fuzzy' : 'linked' }
 511               ->{ $heading->display_form() }++;
 512             next if defined $current_link and $current_link == $authid;
 513
 514             $field->delete_subfield( code => '9' ) if defined $current_link;
 515             $field->add_subfields( '9', $authid );
 516             $num_headings_changed++;
 517         }
 518         else {
 519             if ( defined $current_link
 520                 && (!$allowrelink || C4::Context->preference('LinkerKeepStale')) )
 521             {
 522                 $results{'fuzzy'}->{ $heading->display_form() }++;
 523             }
 524             elsif ( C4::Context->preference('AutoCreateAuthorities') ) {
 525                 if ( _check_valid_auth_link( $current_link, $field ) ) {
 526                     $results{'linked'}->{ $heading->display_form() }++;
 527                 }
 528                 elsif ( !$match_count ) {
 529                     my $authority_type = Koha::Authority::Types->find( $heading->auth_type() );
 530                     my $marcrecordauth = MARC::Record->new();
 531                     if ( C4::Context->preference('marcflavour') eq 'MARC21' ) {
 532                         $marcrecordauth->leader('     nz  a22     o  4500');
 533                         SetMarcUnicodeFlag( $marcrecordauth, 'MARC21' );
 534                     }
 535                     $field->delete_subfield( code => '9' )
 536                       if defined $current_link;
 537                     my @auth_subfields;
 538                     foreach my $subfield ( $field->subfields() ){
 539                         if ( $subfield->[0] =~ /[A-z]/
 540                             && C4::Heading::valid_heading_subfield(
 541                                 $field->tag, $subfield->[0] )
 542                            ){
 543                             push @auth_subfields, $subfield->[0] => $subfield->[1];
 544                         }
 545                     }
 546                     # Bib headings contain some ending punctuation that should NOT
 547                     # be included in the authority record. Strip those before creation
 548                     next unless @auth_subfields; # Don't try to create a record if we have no fields;
 549                     my $last_sub = pop @auth_subfields;
 550                     $last_sub =~ s/[\s]*[,.:=;!%\/][\s]*$//;
 551                     push @auth_subfields, $last_sub;
 552                     my $authfield = MARC::Field->new( $authority_type->auth_tag_to_report, '', '', @auth_subfields );
 553                     $marcrecordauth->insert_fields_ordered($authfield);
 554
 555 # bug 2317: ensure new authority knows it's using UTF-8; currently
 556 # only need to do this for MARC21, as MARC::Record->as_xml_record() handles
 557 # automatically for UNIMARC (by not transcoding)
 558 # FIXME: AddAuthority() instead should simply explicitly require that the MARC::Record
 559 # use UTF-8, but as of 2008-08-05, did not want to introduce that kind
 560 # of change to a core API just before the 3.0 release.
 561
 562                     if ( C4::Context->preference('marcflavour') eq 'MARC21' ) {
 563                         my $userenv = C4::Context->userenv;
 564                         my $library;
 565                         if ( $userenv && $userenv->{'branch'} ) {
 566                             $library = Koha::Libraries->find( $userenv->{'branch'} );
 567                         }
 568                         $marcrecordauth->insert_fields_ordered(
 569                             MARC::Field->new(
 570                                 '667', '', '',
 571                                 'a' => "Machine generated authority record."
 572                             )
 573                         );
 574                         my $cite =
 575                             $bib->author() . ", "
 576                           . $bib->title_proper() . ", "
 577                           . $bib->publication_date() . " ";
 578                         $cite =~ s/^[\s\,]*//;
 579                         $cite =~ s/[\s\,]*$//;
 580                         $cite =
 581                             "Work cat.: ("
 582                           . ( $library ? $library->get_effective_marcorgcode : C4::Context->preference('MARCOrgCode') ) . ")"
 583                           . $bib->subfield( '999', 'c' ) . ": "
 584                           . $cite;
 585                         $marcrecordauth->insert_fields_ordered(
 586                             MARC::Field->new( '670', '', '', 'a' => $cite ) );
 587                     }
 588
 589            #          warn "AUTH RECORD ADDED : ".$marcrecordauth->as_formatted;
 590
 591                     $authid =
 592                       C4::AuthoritiesMarc::AddAuthority( $marcrecordauth, '',
 593                         $heading->auth_type() );
 594                     $field->add_subfields( '9', $authid );
 595                     $num_headings_changed++;
 596                     $linker->update_cache($heading, $authid);
 597                     $results{'added'}->{ $heading->display_form() }++;
 598                 }
 599             }
 600             elsif ( defined $current_link ) {
 601                 if ( _check_valid_auth_link( $current_link, $field ) ) {
 602                     $results{'linked'}->{ $heading->display_form() }++;
 603                 }
 604                 else {
 605                     $field->delete_subfield( code => '9' );
 606                     $num_headings_changed++;
 607                     $results{'unlinked'}->{ $heading->display_form() }++;
 608                 }
 609             }
 610             else {
 611                 $results{'unlinked'}->{ $heading->display_form() }++;
 612             }
 613         }
 614
 615     }
 616     return $num_headings_changed, \%results;
 617 }
 618
 619 =head2 _check_valid_auth_link
 620
 621     if ( _check_valid_auth_link($authid, $field) ) {
 622         ...
 623     }
 624
 625 Check whether the specified heading-auth link is valid without reference
 626 to Zebra. Ideally this code would be in C4::Heading, but that won't be
 627 possible until we have de-cycled C4::AuthoritiesMarc, so this is the
 628 safest place.
 629
 630 =cut
 631
 632 sub _check_valid_auth_link {
 633     my ( $authid, $field ) = @_;
 634     require C4::AuthoritiesMarc;
 635
 636     my $authorized_heading =
 637       C4::AuthoritiesMarc::GetAuthorizedHeading( { 'authid' => $authid } ) || '';
 638    return ($field->as_string('abcdefghijklmnopqrstuvwxyz') eq $authorized_heading);
 639 }
 640
 641 =head2 GetBiblioData
 642
 643   $data = &GetBiblioData($biblionumber);
 644
 645 Returns information about the book with the given biblionumber.
 646 C<&GetBiblioData> returns a reference-to-hash. The keys are the fields in
 647 the C<biblio> and C<biblioitems> tables in the
 648 Koha database.
 649
 650 In addition, C<$data-E<gt>{subject}> is the list of the book's
 651 subjects, separated by C<" , "> (space, comma, space).
 652 If there are multiple biblioitems with the given biblionumber, only
 653 the first one is considered.
 654
 655 =cut
 656
 657 sub GetBiblioData {
 658     my ($bibnum) = @_;
 659     my $dbh = C4::Context->dbh;
 660
 661     my $query = " SELECT * , biblioitems.notes AS bnotes, itemtypes.notforloan as bi_notforloan, biblio.notes
 662             FROM biblio
 663             LEFT JOIN biblioitems ON biblio.biblionumber = biblioitems.biblionumber
 664             LEFT JOIN itemtypes ON biblioitems.itemtype = itemtypes.itemtype
 665             WHERE biblio.biblionumber = ?";
 666
 667     my $sth = $dbh->prepare($query);
 668     $sth->execute($bibnum);
 669     my $data;
 670     $data = $sth->fetchrow_hashref;
 671     $sth->finish;
 672
 673     return ($data);
 674 }    # sub GetBiblioData
 675
 676 =head2 GetISBDView
 677
 678   $isbd = &GetISBDView({
 679       'record'    => $marc_record,
 680       'template'  => $interface, # opac/intranet
 681       'framework' => $framework,
 682   });
 683
 684 Return the ISBD view which can be included in opac and intranet
 685
 686 =cut
 687
 688 sub GetISBDView {
 689     my ( $params ) = @_;
 690
 691     # Expecting record WITH items.
 692     my $record    = $params->{record};
 693     return unless defined $record;
 694
 695     my $template  = $params->{template} // q{};
 696     my $sysprefname = $template eq 'opac' ? 'opacisbd' : 'isbd';
 697     my $framework = $params->{framework};
 698     my $itemtype  = $framework;
 699     my ( $holdingbrtagf, $holdingbrtagsubf ) = &GetMarcFromKohaField( "items.holdingbranch" );
 700     my $tagslib = GetMarcStructure( 1, $itemtype, { unsafe => 1 } );
 701
 702     my $ISBD = C4::Context->preference($sysprefname);
 703     my $bloc = $ISBD;
 704     my $res;
 705     my $blocres;
 706
 707     foreach my $isbdfield ( split( /#/, $bloc ) ) {
 708
 709         #         $isbdfield= /(.?.?.?)/;
 710         $isbdfield =~ /(\d\d\d)([^\|])?\|(.*)\|(.*)\|(.*)/;
 711         my $fieldvalue = $1 || 0;
 712         my $subfvalue  = $2 || "";
 713         my $textbefore = $3;
 714         my $analysestring = $4;
 715         my $textafter     = $5;
 716
 717         #         warn "==> $1 / $2 / $3 / $4";
 718         #         my $fieldvalue=substr($isbdfield,0,3);
 719         if ( $fieldvalue > 0 ) {
 720             my $hasputtextbefore = 0;
 721             my @fieldslist       = $record->field($fieldvalue);
 722             @fieldslist = sort { $a->subfield($holdingbrtagsubf) cmp $b->subfield($holdingbrtagsubf) } @fieldslist if ( $fieldvalue eq $holdingbrtagf );
 723
 724             #         warn "ERROR IN ISBD DEFINITION at : $isbdfield" unless $fieldvalue;
 725             #             warn "FV : $fieldvalue";
 726             if ( $subfvalue ne "" ) {
 727                 # OPAC hidden subfield
 728                 next
 729                   if ( ( $template eq 'opac' )
 730                     && ( $tagslib->{$fieldvalue}->{$subfvalue}->{'hidden'} || 0 ) > 0 );
 731                 foreach my $field (@fieldslist) {
 732                     foreach my $subfield ( $field->subfield($subfvalue) ) {
 733                         my $calculated = $analysestring;
 734                         my $tag        = $field->tag();
 735                         if ( $tag < 10 ) {
 736                         } else {
 737                             my $subfieldvalue = GetAuthorisedValueDesc( $tag, $subfvalue, $subfield, '', $tagslib );
 738                             my $tagsubf = $tag . $subfvalue;
 739                             $calculated =~ s/\{(.?.?.?.?)$tagsubf(.*?)\}/$1$subfieldvalue$2\{$1$tagsubf$2\}/g;
 740                             if ( $template eq "opac" ) { $calculated =~ s#/cgi-bin/koha/[^/]+/([^.]*.pl\?.*)$#opac-$1#g; }
 741
 742                             # field builded, store the result
 743                             if ( $calculated && !$hasputtextbefore ) {    # put textbefore if not done
 744                                 $blocres .= $textbefore;
 745                                 $hasputtextbefore = 1;
 746                             }
 747
 748                             # remove punctuation at start
 749                             $calculated =~ s/^( |;|:|\.|-)*//g;
 750                             $blocres .= $calculated;
 751
 752                         }
 753                     }
 754                 }
 755                 $blocres .= $textafter if $hasputtextbefore;
 756             } else {
 757                 foreach my $field (@fieldslist) {
 758                     my $calculated = $analysestring;
 759                     my $tag        = $field->tag();
 760                     if ( $tag < 10 ) {
 761                     } else {
 762                         my @subf = $field->subfields;
 763                         for my $i ( 0 .. $#subf ) {
 764                             my $valuecode     = $subf[$i][1];
 765                             my $subfieldcode  = $subf[$i][0];
 766                             # OPAC hidden subfield
 767                             next
 768                               if ( ( $template eq 'opac' )
 769                                 && ( $tagslib->{$fieldvalue}->{$subfieldcode}->{'hidden'} || 0 ) > 0 );
 770                             my $subfieldvalue = GetAuthorisedValueDesc( $tag, $subf[$i][0], $subf[$i][1], '', $tagslib );
 771                             my $tagsubf       = $tag . $subfieldcode;
 772
 773                             $calculated =~ s/                  # replace all {{}} codes by the value code.
 774                                   \{\{$tagsubf\}\} # catch the {{actualcode}}
 775                                 /
 776                                   $valuecode     # replace by the value code
 777                                /gx;
 778
 779                             $calculated =~ s/\{(.?.?.?.?)$tagsubf(.*?)\}/$1$subfieldvalue$2\{$1$tagsubf$2\}/g;
 780                             if ( $template eq "opac" ) { $calculated =~ s#/cgi-bin/koha/[^/]+/([^.]*.pl\?.*)$#opac-$1#g; }
 781                         }
 782
 783                         # field builded, store the result
 784                         if ( $calculated && !$hasputtextbefore ) {    # put textbefore if not done
 785                             $blocres .= $textbefore;
 786                             $hasputtextbefore = 1;
 787                         }
 788
 789                         # remove punctuation at start
 790                         $calculated =~ s/^( |;|:|\.|-)*//g;
 791                         $blocres .= $calculated;
 792                     }
 793                 }
 794                 $blocres .= $textafter if $hasputtextbefore;
 795             }
 796         } else {
 797             $blocres .= $isbdfield;
 798         }
 799     }
 800     $res .= $blocres;
 801
 802     $res =~ s/\{(.*?)\}//g;
 803     $res =~ s/\\n/\n/g;
 804     $res =~ s/\n/<br\/>/g;
 805
 806     # remove empty ()
 807     $res =~ s/\(\)//g;
 808
 809     return $res;
 810 }
 811
 812 =head1 FUNCTIONS FOR HANDLING MARC MANAGEMENT
 813
 814 =head2 IsMarcStructureInternal
 815
 816     my $tagslib = C4::Biblio::GetMarcStructure();
 817     for my $tag ( sort keys %$tagslib ) {
 818         next unless $tag;
 819         for my $subfield ( sort keys %{ $tagslib->{$tag} } ) {
 820             next if IsMarcStructureInternal($tagslib->{$tag}{$subfield});
 821         }
 822         # Process subfield
 823     }
 824
 825 GetMarcStructure creates keys (lib, tab, mandatory, repeatable, important) for a display purpose.
 826 These different values should not be processed as valid subfields.
 827
 828 =cut
 829
 830 sub IsMarcStructureInternal {
 831     my ( $subfield ) = @_;
 832     return ref $subfield ? 0 : 1;
 833 }
 834
 835 =head2 GetMarcStructure
 836
 837   $res = GetMarcStructure($forlibrarian, $frameworkcode, [ $params ]);
 838
 839 Returns a reference to a big hash of hash, with the Marc structure for the given frameworkcode
 840 $forlibrarian  :if set to 1, the MARC descriptions are the librarians ones, otherwise it's the public (OPAC) ones
 841 $frameworkcode : the framework code to read
 842 $params allows you to pass { unsafe => 1 } for better performance.
 843
 844 Note: If you call GetMarcStructure with unsafe => 1, do not modify or
 845 even autovivify its contents. It is a cached/shared data structure. Your
 846 changes c/would be passed around in subsequent calls.
 847
 848 =cut
 849
 850 sub GetMarcStructure {
 851     my ( $forlibrarian, $frameworkcode, $params ) = @_;
 852     $frameworkcode = "" unless $frameworkcode;
 853
 854     $forlibrarian = $forlibrarian ? 1 : 0;
 855     my $unsafe = ($params && $params->{unsafe})? 1: 0;
 856     my $cache = Koha::Caches->get_instance();
 857     my $cache_key = "MarcStructure-$forlibrarian-$frameworkcode";
 858     my $cached = $cache->get_from_cache($cache_key, { unsafe => $unsafe });
 859     return $cached if $cached;
 860
 861     my $dbh = C4::Context->dbh;
 862     my $sth = $dbh->prepare(
 863         "SELECT tagfield,liblibrarian,libopac,mandatory,repeatable,important,ind1_defaultvalue,ind2_defaultvalue
 864         FROM marc_tag_structure
 865         WHERE frameworkcode=?
 866         ORDER BY tagfield"
 867     );
 868     $sth->execute($frameworkcode);
 869     my ( $liblibrarian, $libopac, $tag, $res, $tab, $mandatory, $repeatable, $important, $ind1_defaultvalue, $ind2_defaultvalue );
 870
 871     while ( ( $tag, $liblibrarian, $libopac, $mandatory, $repeatable, $important, $ind1_defaultvalue, $ind2_defaultvalue ) = $sth->fetchrow ) {
 872         $res->{$tag}->{lib}        = ( $forlibrarian or !$libopac ) ? $liblibrarian : $libopac;
 873         $res->{$tag}->{tab}        = "";
 874         $res->{$tag}->{mandatory}  = $mandatory;
 875         $res->{$tag}->{important}  = $important;
 876         $res->{$tag}->{repeatable} = $repeatable;
 877     $res->{$tag}->{ind1_defaultvalue} = $ind1_defaultvalue;
 878     $res->{$tag}->{ind2_defaultvalue} = $ind2_defaultvalue;
 879     }
 880
 881     $sth = $dbh->prepare(
 882         "SELECT tagfield,tagsubfield,liblibrarian,libopac,tab,mandatory,repeatable,authorised_value,authtypecode,value_builder,kohafield,seealso,hidden,isurl,link,defaultvalue,maxlength,important
 883          FROM   marc_subfield_structure
 884          WHERE  frameworkcode=?
 885          ORDER BY tagfield,tagsubfield
 886         "
 887     );
 888
 889     $sth->execute($frameworkcode);
 890
 891     my $subfield;
 892     my $authorised_value;
 893     my $authtypecode;
 894     my $value_builder;
 895     my $kohafield;
 896     my $seealso;
 897     my $hidden;
 898     my $isurl;
 899     my $link;
 900     my $defaultvalue;
 901     my $maxlength;
 902
 903     while (
 904         (   $tag,          $subfield,      $liblibrarian, $libopac, $tab,    $mandatory, $repeatable, $authorised_value,
 905             $authtypecode, $value_builder, $kohafield,    $seealso, $hidden, $isurl,     $link,       $defaultvalue,
 906             $maxlength, $important
 907         )
 908         = $sth->fetchrow
 909       ) {
 910         $res->{$tag}->{$subfield}->{lib}              = ( $forlibrarian or !$libopac ) ? $liblibrarian : $libopac;
 911         $res->{$tag}->{$subfield}->{tab}              = $tab;
 912         $res->{$tag}->{$subfield}->{mandatory}        = $mandatory;
 913         $res->{$tag}->{$subfield}->{important}        = $important;
 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, "UTF-8",
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 %hiddenlist = map { $_ => 1 }
1516         split( /,/, C4::Context->preference('NotesToHide'));
1517     foreach my $field ( $record->field($scope) ) {
1518         my $tag = $field->tag();
1519         next if $hiddenlist{ $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 UpsertMarcSubfield
1864
1865     my $record = C4::Biblio::UpsertMarcSubfield($MARC::Record, $fieldTag, $subfieldCode, $subfieldContent);
1866
1867 =cut
1868
1869 sub UpsertMarcSubfield {
1870     my ($record, $tag, $code, $content) = @_;
1871     my $f = $record->field($tag);
1872
1873     if ($f) {
1874         $f->update( $code => $content );
1875     }
1876     else {
1877         my $f = MARC::Field->new( $tag, '', '', $code => $content);
1878         $record->insert_fields_ordered( $f );
1879     }
1880 }
1881
1882 =head2 UpsertMarcControlField
1883
1884     my $record = C4::Biblio::UpsertMarcControlField($MARC::Record, $fieldTag, $content);
1885
1886 =cut
1887
1888 sub UpsertMarcControlField {
1889     my ($record, $tag, $content) = @_;
1890     die "UpsertMarcControlField() \$tag '$tag' is not a control field\n" unless 0+$tag < 10;
1891     my $f = $record->field($tag);
1892
1893     if ($f) {
1894         $f->update( $content );
1895     }
1896     else {
1897         my $f = MARC::Field->new($tag, $content);
1898         $record->insert_fields_ordered( $f );
1899     }
1900 }
1901
1902 =head2 GetFrameworkCode
1903
1904   $frameworkcode = GetFrameworkCode( $biblionumber )
1905
1906 =cut
1907
1908 sub GetFrameworkCode {
1909     my ($biblionumber) = @_;
1910     my $dbh            = C4::Context->dbh;
1911     my $sth            = $dbh->prepare("SELECT frameworkcode FROM biblio WHERE biblionumber=?");
1912     $sth->execute($biblionumber);
1913     my ($frameworkcode) = $sth->fetchrow;
1914     return $frameworkcode;
1915 }
1916
1917 =head2 TransformKohaToMarc
1918
1919     $record = TransformKohaToMarc( $hash [, $params ]  )
1920
1921 This function builds a (partial) MARC::Record from a hash.
1922 Hash entries can be from biblio, biblioitems or items.
1923 The params hash includes the parameter no_split used in C4::Items.
1924
1925 This function is called in acquisition module, to create a basic catalogue
1926 entry from user entry.
1927
1928 =cut
1929
1930
1931 sub TransformKohaToMarc {
1932     my ( $hash, $params ) = @_;
1933     my $record = MARC::Record->new();
1934     SetMarcUnicodeFlag( $record, C4::Context->preference("marcflavour") );
1935
1936     # In the next call we use the Default framework, since it is considered
1937     # authoritative for Koha to Marc mappings.
1938     my $mss = GetMarcSubfieldStructure( '', { unsafe => 1 } ); # do not change framework
1939     my $tag_hr = {};
1940     while ( my ($kohafield, $value) = each %$hash ) {
1941         foreach my $fld ( @{ $mss->{$kohafield} } ) {
1942             my $tagfield    = $fld->{tagfield};
1943             my $tagsubfield = $fld->{tagsubfield};
1944             next if !$tagfield;
1945
1946             # BZ 21800: split value if field is repeatable.
1947             my @values = _check_split($params, $fld, $value)
1948                 ? split(/\s?\|\s?/, $value, -1)
1949                 : ( $value );
1950             foreach my $value ( @values ) {
1951                 next if $value eq '';
1952                 $tag_hr->{$tagfield} //= [];
1953                 push @{$tag_hr->{$tagfield}}, [($tagsubfield, $value)];
1954             }
1955         }
1956     }
1957     foreach my $tag (sort keys %$tag_hr) {
1958         my @sfl = @{$tag_hr->{$tag}};
1959         @sfl = sort { $a->[0] cmp $b->[0]; } @sfl;
1960         @sfl = map { @{$_}; } @sfl;
1961         # Special care for control fields: remove the subfield indication @
1962         # and do not insert indicators.
1963         my @ind = $tag < 10 ? () : ( " ", " " );
1964         @sfl = grep { $_ ne '@' } @sfl if $tag < 10;
1965         $record->insert_fields_ordered( MARC::Field->new($tag, @ind, @sfl) );
1966     }
1967     return $record;
1968 }
1969
1970 sub _check_split {
1971 # Checks if $value must be split; may consult passed framework
1972     my ($params, $fld, $value) = @_;
1973     return if index($value,'|') == -1; # nothing to worry about
1974     return if $params->{no_split};
1975
1976     # if we did not get a specific framework, check default in $mss
1977     return $fld->{repeatable} if !$params->{framework};
1978
1979     # here we need to check the specific framework
1980     my $mss = GetMarcSubfieldStructure($params->{framework}, { unsafe => 1 });
1981     foreach my $fld2 ( @{ $mss->{ $fld->{kohafield} } } ) {
1982         next if $fld2->{tagfield} ne $fld->{tagfield};
1983         next if $fld2->{tagsubfield} ne $fld->{tagsubfield};
1984         return 1 if $fld2->{repeatable};
1985     }
1986     return;
1987 }
1988
1989 =head2 PrepHostMarcField
1990
1991     $hostfield = PrepHostMarcField ( $hostbiblionumber,$hostitemnumber,$marcflavour )
1992
1993 This function returns a host field populated with data from the host record, the field can then be added to an analytical record
1994
1995 =cut
1996
1997 sub PrepHostMarcField {
1998     my ($hostbiblionumber,$hostitemnumber, $marcflavour) = @_;
1999     $marcflavour ||="MARC21";
2000
2001     my $hostrecord = GetMarcBiblio({ biblionumber => $hostbiblionumber });
2002     my $item = Koha::Items->find($hostitemnumber);
2003
2004         my $hostmarcfield;
2005     if ( $marcflavour eq "MARC21" || $marcflavour eq "NORMARC" ) {
2006
2007         #main entry
2008         my $mainentry;
2009         if ($hostrecord->subfield('100','a')){
2010             $mainentry = $hostrecord->subfield('100','a');
2011         } elsif ($hostrecord->subfield('110','a')){
2012             $mainentry = $hostrecord->subfield('110','a');
2013         } else {
2014             $mainentry = $hostrecord->subfield('111','a');
2015         }
2016
2017         # qualification info
2018         my $qualinfo;
2019         if (my $field260 = $hostrecord->field('260')){
2020             $qualinfo =  $field260->as_string( 'abc' );
2021         }
2022
2023
2024         #other fields
2025         my $ed = $hostrecord->subfield('250','a');
2026         my $barcode = $item->barcode;
2027         my $title = $hostrecord->subfield('245','a');
2028
2029         # record control number, 001 with 003 and prefix
2030         my $recctrlno;
2031         if ($hostrecord->field('001')){
2032             $recctrlno = $hostrecord->field('001')->data();
2033             if ($hostrecord->field('003')){
2034                 $recctrlno = '('.$hostrecord->field('003')->data().')'.$recctrlno;
2035             }
2036         }
2037
2038         # issn/isbn
2039         my $issn = $hostrecord->subfield('022','a');
2040         my $isbn = $hostrecord->subfield('020','a');
2041
2042
2043         $hostmarcfield = MARC::Field->new(
2044                 773, '0', '',
2045                 '0' => $hostbiblionumber,
2046                 '9' => $hostitemnumber,
2047                 'a' => $mainentry,
2048                 'b' => $ed,
2049                 'd' => $qualinfo,
2050                 'o' => $barcode,
2051                 't' => $title,
2052                 'w' => $recctrlno,
2053                 'x' => $issn,
2054                 'z' => $isbn
2055                 );
2056     } elsif ($marcflavour eq "UNIMARC") {
2057         $hostmarcfield = MARC::Field->new(
2058             461, '', '',
2059             '0' => $hostbiblionumber,
2060             't' => $hostrecord->subfield('200','a'),
2061             '9' => $hostitemnumber
2062         );
2063     };
2064
2065     return $hostmarcfield;
2066 }
2067
2068 =head2 TransformHtmlToXml
2069
2070   $xml = TransformHtmlToXml( $tags, $subfields, $values, $indicator,
2071                              $ind_tag, $auth_type )
2072
2073 $auth_type contains :
2074
2075 =over
2076
2077 =item - nothing : rebuild a biblio. In UNIMARC the encoding is in 100$a pos 26/27
2078
2079 =item - UNIMARCAUTH : rebuild an authority. In UNIMARC, the encoding is in 100$a pos 13/14
2080
2081 =item - ITEM : rebuild an item : in UNIMARC, 100$a, it's in the biblio ! (otherwise, we would get 2 100 fields !)
2082
2083 =back
2084
2085 =cut
2086
2087 sub TransformHtmlToXml {
2088     my ( $tags, $subfields, $values, $indicator, $ind_tag, $auth_type ) = @_;
2089     # NOTE: The parameter $ind_tag is NOT USED -- BZ 11247
2090
2091     my $xml = MARC::File::XML::header('UTF-8');
2092     $xml .= "<record>\n";
2093     $auth_type = C4::Context->preference('marcflavour') unless $auth_type;
2094     MARC::File::XML->default_record_format($auth_type);
2095
2096     # in UNIMARC, field 100 contains the encoding
2097     # check that there is one, otherwise the
2098     # MARC::Record->new_from_xml will fail (and Koha will die)
2099     my $unimarc_and_100_exist = 0;
2100     $unimarc_and_100_exist = 1 if $auth_type eq 'ITEM';    # if we rebuild an item, no need of a 100 field
2101     my $prevtag = -1;
2102     my $first   = 1;
2103     my $j       = -1;
2104     my $close_last_tag;
2105     for ( my $i = 0 ; $i < @$tags ; $i++ ) {
2106
2107         if ( C4::Context->preference('marcflavour') eq 'UNIMARC' and @$tags[$i] eq "100" and @$subfields[$i] eq "a" ) {
2108
2109             # if we have a 100 field and it's values are not correct, skip them.
2110             # if we don't have any valid 100 field, we will create a default one at the end
2111             my $enc = substr( @$values[$i], 26, 2 );
2112             if ( $enc eq '01' or $enc eq '50' or $enc eq '03' ) {
2113                 $unimarc_and_100_exist = 1;
2114             } else {
2115                 next;
2116             }
2117         }
2118         @$values[$i] =~ s/&/&amp;/g;
2119         @$values[$i] =~ s/</&lt;/g;
2120         @$values[$i] =~ s/>/&gt;/g;
2121         @$values[$i] =~ s/"/&quot;/g;
2122         @$values[$i] =~ s/'/&apos;/g;
2123
2124         if ( ( @$tags[$i] ne $prevtag ) ) {
2125             $close_last_tag = 0;
2126             $j++ unless ( @$tags[$i] eq "" );
2127             my $str = ( $indicator->[$j] // q{} ) . '  '; # extra space prevents substr outside of string warn
2128             my $ind1 = _default_ind_to_space( substr( $str, 0, 1 ) );
2129             my $ind2 = _default_ind_to_space( substr( $str, 1, 1 ) );
2130             if ( !$first ) {
2131                 $xml .= "</datafield>\n";
2132                 if (   ( @$tags[$i] && @$tags[$i] > 10 )
2133                     && ( @$values[$i] ne "" ) ) {
2134                     $xml .= "<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
2135                     $xml .= "<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
2136                     $first = 0;
2137                     $close_last_tag = 1;
2138                 } else {
2139                     $first = 1;
2140                 }
2141             } else {
2142                 if ( @$values[$i] ne "" ) {
2143
2144                     # leader
2145                     if ( @$tags[$i] eq "000" ) {
2146                         $xml .= "<leader>@$values[$i]</leader>\n";
2147                         $first = 1;
2148
2149                         # rest of the fixed fields
2150                     } elsif ( @$tags[$i] < 10 ) {
2151                         $xml .= "<controlfield tag=\"@$tags[$i]\">@$values[$i]</controlfield>\n";
2152                         $first = 1;
2153                     } else {
2154                         $xml .= "<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
2155                         $xml .= "<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
2156                         $first = 0;
2157                         $close_last_tag = 1;
2158                     }
2159                 }
2160             }
2161         } else {    # @$tags[$i] eq $prevtag
2162             if ( @$values[$i] eq "" ) {
2163             } else {
2164                 if ($first) {
2165                     my $str = ( $indicator->[$j] // q{} ) . '  '; # extra space prevents substr outside of string warn
2166                     my $ind1 = _default_ind_to_space( substr( $str, 0, 1 ) );
2167                     my $ind2 = _default_ind_to_space( substr( $str, 1, 1 ) );
2168                     $xml .= "<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
2169                     $first = 0;
2170                     $close_last_tag = 1;
2171                 }
2172                 $xml .= "<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
2173             }
2174         }
2175         $prevtag = @$tags[$i];
2176     }
2177     $xml .= "</datafield>\n" if $close_last_tag;
2178     if ( C4::Context->preference('marcflavour') eq 'UNIMARC' and !$unimarc_and_100_exist ) {
2179
2180         #     warn "SETTING 100 for $auth_type";
2181         my $string = strftime( "%Y%m%d", localtime(time) );
2182
2183         # set 50 to position 26 is biblios, 13 if authorities
2184         my $pos = 26;
2185         $pos = 13 if $auth_type eq 'UNIMARCAUTH';
2186         $string = sprintf( "%-*s", 35, $string );
2187         substr( $string, $pos, 6, "50" );
2188         $xml .= "<datafield tag=\"100\" ind1=\"\" ind2=\"\">\n";
2189         $xml .= "<subfield code=\"a\">$string</subfield>\n";
2190         $xml .= "</datafield>\n";
2191     }
2192     $xml .= "</record>\n";
2193     $xml .= MARC::File::XML::footer();
2194     return $xml;
2195 }
2196
2197 =head2 _default_ind_to_space
2198
2199 Passed what should be an indicator returns a space
2200 if its undefined or zero length
2201
2202 =cut
2203
2204 sub _default_ind_to_space {
2205     my $s = shift;
2206     if ( !defined $s || $s eq q{} ) {
2207         return ' ';
2208     }
2209     return $s;
2210 }
2211
2212 =head2 TransformHtmlToMarc
2213
2214     L<$record> = TransformHtmlToMarc(L<$cgi>)
2215     L<$cgi> is the CGI object which contains the values for subfields
2216     {
2217         'tag_010_indicator1_531951' ,
2218         'tag_010_indicator2_531951' ,
2219         'tag_010_code_a_531951_145735' ,
2220         'tag_010_subfield_a_531951_145735' ,
2221         'tag_200_indicator1_873510' ,
2222         'tag_200_indicator2_873510' ,
2223         'tag_200_code_a_873510_673465' ,
2224         'tag_200_subfield_a_873510_673465' ,
2225         'tag_200_code_b_873510_704318' ,
2226         'tag_200_subfield_b_873510_704318' ,
2227         'tag_200_code_e_873510_280822' ,
2228         'tag_200_subfield_e_873510_280822' ,
2229         'tag_200_code_f_873510_110730' ,
2230         'tag_200_subfield_f_873510_110730' ,
2231     }
2232     L<$record> is the MARC::Record object.
2233
2234 =cut
2235
2236 sub TransformHtmlToMarc {
2237     my ($cgi, $isbiblio) = @_;
2238
2239     my @params = $cgi->multi_param();
2240
2241     # explicitly turn on the UTF-8 flag for all
2242     # 'tag_' parameters to avoid incorrect character
2243     # conversion later on
2244     my $cgi_params = $cgi->Vars;
2245     foreach my $param_name ( keys %$cgi_params ) {
2246         if ( $param_name =~ /^tag_/ ) {
2247             my $param_value = $cgi_params->{$param_name};
2248             unless ( Encode::is_utf8( $param_value ) ) {
2249                 $cgi_params->{$param_name} = Encode::decode('UTF-8', $param_value );
2250             }
2251         }
2252     }
2253
2254     # creating a new record
2255     my $record = MARC::Record->new();
2256     my @fields;
2257     my ($biblionumbertagfield, $biblionumbertagsubfield) = (-1, -1);
2258     ($biblionumbertagfield, $biblionumbertagsubfield) =
2259         &GetMarcFromKohaField( "biblio.biblionumber", '' ) if $isbiblio;
2260 #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!
2261     for (my $i = 0; $params[$i]; $i++ ) {    # browse all CGI params
2262         my $param    = $params[$i];
2263         my $newfield = 0;
2264
2265         # if we are on biblionumber, store it in the MARC::Record (it may not be in the edited fields)
2266         if ( $param eq 'biblionumber' ) {
2267             if ( $biblionumbertagfield < 10 ) {
2268                 $newfield = MARC::Field->new( $biblionumbertagfield, scalar $cgi->param($param), );
2269             } else {
2270                 $newfield = MARC::Field->new( $biblionumbertagfield, '', '', "$biblionumbertagsubfield" => scalar $cgi->param($param), );
2271             }
2272             push @fields, $newfield if ($newfield);
2273         } elsif ( $param =~ /^tag_(\d*)_indicator1_/ ) {    # new field start when having 'input name="..._indicator1_..."
2274             my $tag = $1;
2275
2276             my $ind1 = _default_ind_to_space( substr( $cgi->param($param), 0, 1 ) );
2277             my $ind2 = _default_ind_to_space( substr( $cgi->param( $params[ $i + 1 ] ), 0, 1 ) );
2278             $newfield = 0;
2279             my $j = $i + 2;
2280
2281             if ( $tag < 10 ) {                              # no code for theses fields
2282                                                             # in MARC editor, 000 contains the leader.
2283                 next if $tag == $biblionumbertagfield;
2284                 my $fval= $cgi->param($params[$j+1]);
2285                 if ( $tag eq '000' ) {
2286                     # Force a fake leader even if not provided to avoid crashing
2287                     # during decoding MARC record containing UTF-8 characters
2288                     $record->leader(
2289                         length( $fval ) == 24
2290                         ? $fval
2291                         : '     nam a22        4500'
2292                         )
2293                     ;
2294                     # between 001 and 009 (included)
2295                 } elsif ( $fval ne '' ) {
2296                     $newfield = MARC::Field->new( $tag, $fval, );
2297                 }
2298
2299                 # > 009, deal with subfields
2300             } else {
2301                 # browse subfields for this tag (reason for _code_ match)
2302                 while(defined $params[$j] && $params[$j] =~ /_code_/) {
2303                     last unless defined $params[$j+1];
2304                     $j += 2 and next
2305                         if $tag == $biblionumbertagfield and
2306                            $cgi->param($params[$j]) eq $biblionumbertagsubfield;
2307                     #if next param ne subfield, then it was probably empty
2308                     #try next param by incrementing j
2309                     if($params[$j+1]!~/_subfield_/) {$j++; next; }
2310                     my $fkey= $cgi->param($params[$j]);
2311                     my $fval= $cgi->param($params[$j+1]);
2312                     #check if subfield value not empty and field exists
2313                     if($fval ne '' && $newfield) {
2314                         $newfield->add_subfields( $fkey => $fval);
2315                     }
2316                     elsif($fval ne '') {
2317                         $newfield = MARC::Field->new( $tag, $ind1, $ind2, $fkey => $fval );
2318                     }
2319                     $j += 2;
2320                 } #end-of-while
2321                 $i= $j-1; #update i for outer loop accordingly
2322             }
2323             push @fields, $newfield if ($newfield);
2324         }
2325     }
2326
2327     @fields = sort { $a->tag() cmp $b->tag() } @fields;
2328     $record->append_fields(@fields);
2329     return $record;
2330 }
2331
2332 =head2 TransformMarcToKoha
2333
2334     $result = TransformMarcToKoha( $record, undef, $limit )
2335
2336 Extract data from a MARC bib record into a hashref representing
2337 Koha biblio, biblioitems, and items fields.
2338
2339 If passed an undefined record will log the error and return an empty
2340 hash_ref.
2341
2342 =cut
2343
2344 sub TransformMarcToKoha {
2345     my ( $record, $frameworkcode, $limit_table ) = @_;
2346     # FIXME  Parameter $frameworkcode is obsolete and will be removed
2347     $limit_table //= q{};
2348
2349     my $result = {};
2350     if (!defined $record) {
2351         carp('TransformMarcToKoha called with undefined record');
2352         return $result;
2353     }
2354
2355     my %tables = ( biblio => 1, biblioitems => 1, items => 1 );
2356     if( $limit_table eq 'items' ) {
2357         %tables = ( items => 1 );
2358     }
2359
2360     # The next call acknowledges Default as the authoritative framework
2361     # for Koha to MARC mappings.
2362     my $mss = GetMarcSubfieldStructure( '', { unsafe => 1 } ); # Do not change framework
2363     foreach my $kohafield ( keys %{ $mss } ) {
2364         my ( $table, $column ) = split /[.]/, $kohafield, 2;
2365         next unless $tables{$table};
2366         my $val = TransformMarcToKohaOneField( $kohafield, $record );
2367         next if !defined $val;
2368         my $key = _disambiguate( $table, $column );
2369         $result->{$key} = $val;
2370     }
2371     return $result;
2372 }
2373
2374 =head2 _disambiguate
2375
2376   $newkey = _disambiguate($table, $field);
2377
2378 This is a temporary hack to distinguish between the
2379 following sets of columns when using TransformMarcToKoha.
2380
2381   items.cn_source & biblioitems.cn_source
2382   items.cn_sort & biblioitems.cn_sort
2383
2384 Columns that are currently NOT distinguished (FIXME
2385 due to lack of time to fully test) are:
2386
2387   biblio.notes and biblioitems.notes
2388   biblionumber
2389   timestamp
2390   biblioitemnumber
2391
2392 FIXME - this is necessary because prefixing each column
2393 name with the table name would require changing lots
2394 of code and templates, and exposing more of the DB
2395 structure than is good to the UI templates, particularly
2396 since biblio and bibloitems may well merge in a future
2397 version.  In the future, it would also be good to
2398 separate DB access and UI presentation field names
2399 more.
2400
2401 =cut
2402
2403 sub _disambiguate {
2404     my ( $table, $column ) = @_;
2405     if ( $column eq "cn_sort" or $column eq "cn_source" ) {
2406         return $table . '.' . $column;
2407     } else {
2408         return $column;
2409     }
2410
2411 }
2412
2413 =head2 TransformMarcToKohaOneField
2414
2415     $val = TransformMarcToKohaOneField( 'biblio.title', $marc );
2416
2417     Note: The authoritative Default framework is used implicitly.
2418
2419 =cut
2420
2421 sub TransformMarcToKohaOneField {
2422     my ( $kohafield, $marc ) = @_;
2423
2424     my ( @rv, $retval );
2425     my @mss = GetMarcSubfieldStructureFromKohaField($kohafield);
2426     foreach my $fldhash ( @mss ) {
2427         my $tag = $fldhash->{tagfield};
2428         my $sub = $fldhash->{tagsubfield};
2429         foreach my $fld ( $marc->field($tag) ) {
2430             if( $sub eq '@' || $fld->is_control_field ) {
2431                 push @rv, $fld->data if $fld->data;
2432             } else {
2433                 push @rv, grep { $_ } $fld->subfield($sub);
2434             }
2435         }
2436     }
2437     return unless @rv;
2438     $retval = join ' | ', uniq(@rv);
2439
2440     # Additional polishing for individual kohafields
2441     if( $kohafield =~ /copyrightdate|publicationyear/ ) {
2442         $retval = _adjust_pubyear( $retval );
2443     }
2444
2445     return $retval;
2446 }
2447
2448 =head2 _adjust_pubyear
2449
2450     Helper routine for TransformMarcToKohaOneField
2451
2452 =cut
2453
2454 sub _adjust_pubyear {
2455     my $retval = shift;
2456     # modify return value to keep only the 1st year found
2457     if( $retval =~ m/c(\d\d\d\d)/ and $1 > 0 ) { # search cYYYY first
2458         $retval = $1;
2459     } elsif( $retval =~ m/(\d\d\d\d)/ && $1 > 0 ) {
2460         $retval = $1;
2461     } elsif( $retval =~ m/
2462              (?<year>\d)[-]?[.Xx?]{3}
2463             |(?<year>\d{2})[.Xx?]{2}
2464             |(?<year>\d{3})[.Xx?]
2465             |(?<year>\d)[-]{3}\?
2466             |(?<year>\d\d)[-]{2}\?
2467             |(?<year>\d{3})[-]\?
2468     /xms ) { # the form 198-? occurred in Dutch ISBD rules
2469         my $digits = $+{year};
2470         $retval = $digits * ( 10 ** ( 4 - length($digits) ));
2471     }
2472     return $retval;
2473 }
2474
2475 =head2 CountItemsIssued
2476
2477     my $count = CountItemsIssued( $biblionumber );
2478
2479 =cut
2480
2481 sub CountItemsIssued {
2482     my ($biblionumber) = @_;
2483     my $dbh            = C4::Context->dbh;
2484     my $sth            = $dbh->prepare('SELECT COUNT(*) as issuedCount FROM items, issues WHERE items.itemnumber = issues.itemnumber AND items.biblionumber = ?');
2485     $sth->execute($biblionumber);
2486     my $row = $sth->fetchrow_hashref();
2487     return $row->{'issuedCount'};
2488 }
2489
2490 =head2 ModZebra
2491
2492   ModZebra( $biblionumber, $op, $server, $record );
2493
2494 $biblionumber is the biblionumber we want to index
2495
2496 $op is specialUpdate or recordDelete, and is used to know what we want to do
2497
2498 $server is the server that we want to update
2499
2500 $record is the update MARC record if it's available. If it's not supplied
2501 and is needed, it'll be loaded from the database.
2502
2503 =cut
2504
2505 sub ModZebra {
2506 ###Accepts a $server variable thus we can use it for biblios authorities or other zebra dbs
2507     my ( $biblionumber, $op, $server, $record ) = @_;
2508     $debug && warn "ModZebra: update requested for: $biblionumber $op $server\n";
2509     if ( C4::Context->preference('SearchEngine') eq 'Elasticsearch' ) {
2510
2511         # TODO abstract to a standard API that'll work for whatever
2512         require Koha::SearchEngine::Elasticsearch::Indexer;
2513         my $indexer = Koha::SearchEngine::Elasticsearch::Indexer->new(
2514             {
2515                 index => $server eq 'biblioserver'
2516                 ? $Koha::SearchEngine::BIBLIOS_INDEX
2517                 : $Koha::SearchEngine::AUTHORITIES_INDEX
2518             }
2519         );
2520         if ( $op eq 'specialUpdate' ) {
2521             unless ($record) {
2522                 $record = GetMarcBiblio({
2523                     biblionumber => $biblionumber,
2524                     embed_items  => 1 });
2525             }
2526             my $records = [$record];
2527             $indexer->update_index_background( [$biblionumber], [$record] );
2528         }
2529         elsif ( $op eq 'recordDelete' ) {
2530             $indexer->delete_index_background( [$biblionumber] );
2531         }
2532         else {
2533             croak "ModZebra called with unknown operation: $op";
2534         }
2535     }
2536
2537     my $dbh = C4::Context->dbh;
2538
2539     # true ModZebra commented until indexdata fixes zebraDB crashes (it seems they occur on multiple updates
2540     # at the same time
2541     # replaced by a zebraqueue table, that is filled with ModZebra to run.
2542     # the table is emptied by rebuild_zebra.pl script (using the -z switch)
2543     my $check_sql = "SELECT COUNT(*) FROM zebraqueue
2544     WHERE server = ?
2545         AND   biblio_auth_number = ?
2546         AND   operation = ?
2547         AND   done = 0";
2548     my $check_sth = $dbh->prepare_cached($check_sql);
2549     $check_sth->execute( $server, $biblionumber, $op );
2550     my ($count) = $check_sth->fetchrow_array;
2551     $check_sth->finish();
2552     if ( $count == 0 ) {
2553         my $sth = $dbh->prepare("INSERT INTO zebraqueue  (biblio_auth_number,server,operation) VALUES(?,?,?)");
2554         $sth->execute( $biblionumber, $server, $op );
2555         $sth->finish;
2556     }
2557 }
2558
2559
2560 =head2 EmbedItemsInMarcBiblio
2561
2562     EmbedItemsInMarcBiblio({
2563         marc_record  => $marc,
2564         biblionumber => $biblionumber,
2565         item_numbers => $itemnumbers,
2566         opac         => $opac });
2567
2568 Given a MARC::Record object containing a bib record,
2569 modify it to include the items attached to it as 9XX
2570 per the bib's MARC framework.
2571 if $itemnumbers is defined, only specified itemnumbers are embedded.
2572
2573 If $opac is true, then opac-relevant suppressions are included.
2574
2575 If opac filtering will be done, borcat should be passed to properly
2576 override if necessary.
2577
2578 =cut
2579
2580 sub EmbedItemsInMarcBiblio {
2581     my ($params) = @_;
2582     my ($marc, $biblionumber, $itemnumbers, $opac, $borcat);
2583     $marc = $params->{marc_record};
2584     if ( !$marc ) {
2585         carp 'EmbedItemsInMarcBiblio: No MARC record passed';
2586         return;
2587     }
2588     $biblionumber = $params->{biblionumber};
2589     $itemnumbers = $params->{item_numbers};
2590     $opac = $params->{opac};
2591     $borcat = $params->{borcat} // q{};
2592
2593     $itemnumbers = [] unless defined $itemnumbers;
2594
2595     my $frameworkcode = GetFrameworkCode($biblionumber);
2596     _strip_item_fields($marc, $frameworkcode);
2597
2598     # ... and embed the current items
2599     my $dbh = C4::Context->dbh;
2600     my $sth = $dbh->prepare("SELECT itemnumber FROM items WHERE biblionumber = ?");
2601     $sth->execute($biblionumber);
2602     my ( $itemtag, $itemsubfield ) = GetMarcFromKohaField( "items.itemnumber" );
2603
2604     my @item_fields; # Array holding the actual MARC data for items to be included.
2605     my @items;       # Array holding items which are both in the list (sitenumbers)
2606                      # and on this biblionumber
2607
2608     # Flag indicating if there is potential hiding.
2609     my $opachiddenitems = $opac
2610       && ( C4::Context->preference('OpacHiddenItems') !~ /^\s*$/ );
2611
2612     require C4::Items;
2613     while ( my ($itemnumber) = $sth->fetchrow_array ) {
2614         next if @$itemnumbers and not grep { $_ == $itemnumber } @$itemnumbers;
2615         my $item;
2616         if ( $opachiddenitems ) {
2617             $item = Koha::Items->find($itemnumber);
2618             $item = $item ? $item->unblessed : undef;
2619         }
2620         push @items, { itemnumber => $itemnumber, item => $item };
2621     }
2622     my @items2pass = map { $_->{item} } @items;
2623     my @hiddenitems =
2624       $opachiddenitems
2625       ? C4::Items::GetHiddenItemnumbers({
2626             items  => \@items2pass,
2627             borcat => $borcat })
2628       : ();
2629     # Convert to a hash for quick searching
2630     my %hiddenitems = map { $_ => 1 } @hiddenitems;
2631     foreach my $itemnumber ( map { $_->{itemnumber} } @items ) {
2632         next if $hiddenitems{$itemnumber};
2633         my $item_marc = C4::Items::GetMarcItem( $biblionumber, $itemnumber );
2634         push @item_fields, $item_marc->field($itemtag);
2635     }
2636     $marc->append_fields(@item_fields);
2637 }
2638
2639 =head1 INTERNAL FUNCTIONS
2640
2641 =head2 _koha_marc_update_bib_ids
2642
2643
2644   _koha_marc_update_bib_ids($record, $frameworkcode, $biblionumber, $biblioitemnumber);
2645
2646 Internal function to add or update biblionumber and biblioitemnumber to
2647 the MARC XML.
2648
2649 =cut
2650
2651 sub _koha_marc_update_bib_ids {
2652     my ( $record, $frameworkcode, $biblionumber, $biblioitemnumber ) = @_;
2653
2654     my ( $biblio_tag,     $biblio_subfield )     = GetMarcFromKohaField( "biblio.biblionumber" );
2655     die qq{No biblionumber tag for framework "$frameworkcode"} unless $biblio_tag;
2656     my ( $biblioitem_tag, $biblioitem_subfield ) = GetMarcFromKohaField( "biblioitems.biblioitemnumber" );
2657     die qq{No biblioitemnumber tag for framework "$frameworkcode"} unless $biblioitem_tag;
2658
2659     if ( $biblio_tag < 10 ) {
2660         C4::Biblio::UpsertMarcControlField( $record, $biblio_tag, $biblionumber );
2661     } else {
2662         C4::Biblio::UpsertMarcSubfield($record, $biblio_tag, $biblio_subfield, $biblionumber);
2663     }
2664     if ( $biblioitem_tag < 10 ) {
2665         C4::Biblio::UpsertMarcControlField( $record, $biblioitem_tag, $biblioitemnumber );
2666     } else {
2667         C4::Biblio::UpsertMarcSubfield($record, $biblioitem_tag, $biblioitem_subfield, $biblioitemnumber);
2668     }
2669 }
2670
2671 =head2 _koha_marc_update_biblioitem_cn_sort
2672
2673   _koha_marc_update_biblioitem_cn_sort($marc, $biblioitem, $frameworkcode);
2674
2675 Given a MARC bib record and the biblioitem hash, update the
2676 subfield that contains a copy of the value of biblioitems.cn_sort.
2677
2678 =cut
2679
2680 sub _koha_marc_update_biblioitem_cn_sort {
2681     my $marc          = shift;
2682     my $biblioitem    = shift;
2683     my $frameworkcode = shift;
2684
2685     my ( $biblioitem_tag, $biblioitem_subfield ) = GetMarcFromKohaField( "biblioitems.cn_sort" );
2686     return unless $biblioitem_tag;
2687
2688     my ($cn_sort) = GetClassSort( $biblioitem->{'biblioitems.cn_source'}, $biblioitem->{'cn_class'}, $biblioitem->{'cn_item'} );
2689
2690     if ( my $field = $marc->field($biblioitem_tag) ) {
2691         $field->delete_subfield( code => $biblioitem_subfield );
2692         if ( $cn_sort ne '' ) {
2693             $field->add_subfields( $biblioitem_subfield => $cn_sort );
2694         }
2695     } else {
2696
2697         # if we get here, no biblioitem tag is present in the MARC record, so
2698         # we'll create it if $cn_sort is not empty -- this would be
2699         # an odd combination of events, however
2700         if ($cn_sort) {
2701             $marc->insert_grouped_field( MARC::Field->new( $biblioitem_tag, ' ', ' ', $biblioitem_subfield => $cn_sort ) );
2702         }
2703     }
2704 }
2705
2706 =head2 _koha_add_biblio
2707
2708   my ($biblionumber,$error) = _koha_add_biblio($dbh,$biblioitem);
2709
2710 Internal function to add a biblio ($biblio is a hash with the values)
2711
2712 =cut
2713
2714 sub _koha_add_biblio {
2715     my ( $dbh, $biblio, $frameworkcode ) = @_;
2716
2717     my $error;
2718
2719     # set the series flag
2720     unless (defined $biblio->{'serial'}){
2721         $biblio->{'serial'} = 0;
2722         if ( $biblio->{'seriestitle'} ) { $biblio->{'serial'} = 1 }
2723     }
2724
2725     my $query = "INSERT INTO biblio
2726         SET frameworkcode = ?,
2727             author = ?,
2728             title = ?,
2729             subtitle = ?,
2730             medium = ?,
2731             part_number = ?,
2732             part_name = ?,
2733             unititle =?,
2734             notes = ?,
2735             serial = ?,
2736             seriestitle = ?,
2737             copyrightdate = ?,
2738             datecreated=NOW(),
2739             abstract = ?
2740         ";
2741     my $sth = $dbh->prepare($query);
2742     $sth->execute(
2743         $frameworkcode,        $biblio->{'author'},      $biblio->{'title'},       $biblio->{'subtitle'},
2744         $biblio->{'medium'},   $biblio->{'part_number'}, $biblio->{'part_name'},   $biblio->{'unititle'},
2745         $biblio->{'notes'},    $biblio->{'serial'},      $biblio->{'seriestitle'}, $biblio->{'copyrightdate'},
2746         $biblio->{'abstract'}
2747     );
2748
2749     my $biblionumber = $dbh->{'mysql_insertid'};
2750     if ( $dbh->errstr ) {
2751         $error .= "ERROR in _koha_add_biblio $query" . $dbh->errstr;
2752         warn $error;
2753     }
2754
2755     $sth->finish();
2756
2757     #warn "LEAVING _koha_add_biblio: ".$biblionumber."\n";
2758     return ( $biblionumber, $error );
2759 }
2760
2761 =head2 _koha_modify_biblio
2762
2763   my ($biblionumber,$error) == _koha_modify_biblio($dbh,$biblio,$frameworkcode);
2764
2765 Internal function for updating the biblio table
2766
2767 =cut
2768
2769 sub _koha_modify_biblio {
2770     my ( $dbh, $biblio, $frameworkcode ) = @_;
2771     my $error;
2772
2773     my $query = "
2774         UPDATE biblio
2775         SET    frameworkcode = ?,
2776                author = ?,
2777                title = ?,
2778                subtitle = ?,
2779                medium = ?,
2780                part_number = ?,
2781                part_name = ?,
2782                unititle = ?,
2783                notes = ?,
2784                serial = ?,
2785                seriestitle = ?,
2786                copyrightdate = ?,
2787                abstract = ?
2788         WHERE  biblionumber = ?
2789         "
2790       ;
2791     my $sth = $dbh->prepare($query);
2792
2793     $sth->execute(
2794         $frameworkcode,        $biblio->{'author'},      $biblio->{'title'},       $biblio->{'subtitle'},
2795         $biblio->{'medium'},   $biblio->{'part_number'}, $biblio->{'part_name'},   $biblio->{'unititle'},
2796         $biblio->{'notes'},    $biblio->{'serial'},      $biblio->{'seriestitle'}, $biblio->{'copyrightdate'} ? int($biblio->{'copyrightdate'}) : undef,
2797         $biblio->{'abstract'}, $biblio->{'biblionumber'}
2798     ) if $biblio->{'biblionumber'};
2799
2800     if ( $dbh->errstr || !$biblio->{'biblionumber'} ) {
2801         $error .= "ERROR in _koha_modify_biblio $query" . $dbh->errstr;
2802         warn $error;
2803     }
2804     return ( $biblio->{'biblionumber'}, $error );
2805 }
2806
2807 =head2 _koha_modify_biblioitem_nonmarc
2808
2809   my ($biblioitemnumber,$error) = _koha_modify_biblioitem_nonmarc( $dbh, $biblioitem );
2810
2811 =cut
2812
2813 sub _koha_modify_biblioitem_nonmarc {
2814     my ( $dbh, $biblioitem ) = @_;
2815     my $error;
2816
2817     # re-calculate the cn_sort, it may have changed
2818     my ($cn_sort) = GetClassSort( $biblioitem->{'biblioitems.cn_source'}, $biblioitem->{'cn_class'}, $biblioitem->{'cn_item'} );
2819
2820     my $query = "UPDATE biblioitems
2821     SET biblionumber    = ?,
2822         volume          = ?,
2823         number          = ?,
2824         itemtype        = ?,
2825         isbn            = ?,
2826         issn            = ?,
2827         publicationyear = ?,
2828         publishercode   = ?,
2829         volumedate      = ?,
2830         volumedesc      = ?,
2831         collectiontitle = ?,
2832         collectionissn  = ?,
2833         collectionvolume= ?,
2834         editionstatement= ?,
2835         editionresponsibility = ?,
2836         illus           = ?,
2837         pages           = ?,
2838         notes           = ?,
2839         size            = ?,
2840         place           = ?,
2841         lccn            = ?,
2842         url             = ?,
2843         cn_source       = ?,
2844         cn_class        = ?,
2845         cn_item         = ?,
2846         cn_suffix       = ?,
2847         cn_sort         = ?,
2848         totalissues     = ?,
2849         ean             = ?,
2850         agerestriction  = ?
2851         where biblioitemnumber = ?
2852         ";
2853     my $sth = $dbh->prepare($query);
2854     $sth->execute(
2855         $biblioitem->{'biblionumber'},     $biblioitem->{'volume'},           $biblioitem->{'number'},                $biblioitem->{'itemtype'},
2856         $biblioitem->{'isbn'},             $biblioitem->{'issn'},             $biblioitem->{'publicationyear'},       $biblioitem->{'publishercode'},
2857         $biblioitem->{'volumedate'},       $biblioitem->{'volumedesc'},       $biblioitem->{'collectiontitle'},       $biblioitem->{'collectionissn'},
2858         $biblioitem->{'collectionvolume'}, $biblioitem->{'editionstatement'}, $biblioitem->{'editionresponsibility'}, $biblioitem->{'illus'},
2859         $biblioitem->{'pages'},            $biblioitem->{'bnotes'},           $biblioitem->{'size'},                  $biblioitem->{'place'},
2860         $biblioitem->{'lccn'},             $biblioitem->{'url'},              $biblioitem->{'biblioitems.cn_source'}, $biblioitem->{'cn_class'},
2861         $biblioitem->{'cn_item'},          $biblioitem->{'cn_suffix'},        $cn_sort,                               $biblioitem->{'totalissues'},
2862         $biblioitem->{'ean'},              $biblioitem->{'agerestriction'},   $biblioitem->{'biblioitemnumber'}
2863     );
2864     if ( $dbh->errstr ) {
2865         $error .= "ERROR in _koha_modify_biblioitem_nonmarc $query" . $dbh->errstr;
2866         warn $error;
2867     }
2868     return ( $biblioitem->{'biblioitemnumber'}, $error );
2869 }
2870
2871 =head2 _koha_add_biblioitem
2872
2873   my ($biblioitemnumber,$error) = _koha_add_biblioitem( $dbh, $biblioitem );
2874
2875 Internal function to add a biblioitem
2876
2877 =cut
2878
2879 sub _koha_add_biblioitem {
2880     my ( $dbh, $biblioitem ) = @_;
2881     my $error;
2882
2883     my ($cn_sort) = GetClassSort( $biblioitem->{'biblioitems.cn_source'}, $biblioitem->{'cn_class'}, $biblioitem->{'cn_item'} );
2884     my $query = "INSERT INTO biblioitems SET
2885         biblionumber    = ?,
2886         volume          = ?,
2887         number          = ?,
2888         itemtype        = ?,
2889         isbn            = ?,
2890         issn            = ?,
2891         publicationyear = ?,
2892         publishercode   = ?,
2893         volumedate      = ?,
2894         volumedesc      = ?,
2895         collectiontitle = ?,
2896         collectionissn  = ?,
2897         collectionvolume= ?,
2898         editionstatement= ?,
2899         editionresponsibility = ?,
2900         illus           = ?,
2901         pages           = ?,
2902         notes           = ?,
2903         size            = ?,
2904         place           = ?,
2905         lccn            = ?,
2906         url             = ?,
2907         cn_source       = ?,
2908         cn_class        = ?,
2909         cn_item         = ?,
2910         cn_suffix       = ?,
2911         cn_sort         = ?,
2912         totalissues     = ?,
2913         ean             = ?,
2914         agerestriction  = ?
2915         ";
2916     my $sth = $dbh->prepare($query);
2917     $sth->execute(
2918         $biblioitem->{'biblionumber'},     $biblioitem->{'volume'},           $biblioitem->{'number'},                $biblioitem->{'itemtype'},
2919         $biblioitem->{'isbn'},             $biblioitem->{'issn'},             $biblioitem->{'publicationyear'},       $biblioitem->{'publishercode'},
2920         $biblioitem->{'volumedate'},       $biblioitem->{'volumedesc'},       $biblioitem->{'collectiontitle'},       $biblioitem->{'collectionissn'},
2921         $biblioitem->{'collectionvolume'}, $biblioitem->{'editionstatement'}, $biblioitem->{'editionresponsibility'}, $biblioitem->{'illus'},
2922         $biblioitem->{'pages'},            $biblioitem->{'bnotes'},           $biblioitem->{'size'},                  $biblioitem->{'place'},
2923         $biblioitem->{'lccn'},             $biblioitem->{'url'},                   $biblioitem->{'biblioitems.cn_source'},
2924         $biblioitem->{'cn_class'},         $biblioitem->{'cn_item'},          $biblioitem->{'cn_suffix'},             $cn_sort,
2925         $biblioitem->{'totalissues'},      $biblioitem->{'ean'},              $biblioitem->{'agerestriction'}
2926     );
2927     my $bibitemnum = $dbh->{'mysql_insertid'};
2928
2929     if ( $dbh->errstr ) {
2930         $error .= "ERROR in _koha_add_biblioitem $query" . $dbh->errstr;
2931         warn $error;
2932     }
2933     $sth->finish();
2934     return ( $bibitemnum, $error );
2935 }
2936
2937 =head2 _koha_delete_biblio
2938
2939   $error = _koha_delete_biblio($dbh,$biblionumber);
2940
2941 Internal sub for deleting from biblio table -- also saves to deletedbiblio
2942
2943 C<$dbh> - the database handle
2944
2945 C<$biblionumber> - the biblionumber of the biblio to be deleted
2946
2947 =cut
2948
2949 # FIXME: add error handling
2950
2951 sub _koha_delete_biblio {
2952     my ( $dbh, $biblionumber ) = @_;
2953
2954     # get all the data for this biblio
2955     my $sth = $dbh->prepare("SELECT * FROM biblio WHERE biblionumber=?");
2956     $sth->execute($biblionumber);
2957
2958     # FIXME There is a transaction in _koha_delete_biblio_metadata
2959     # But actually all the following should be done inside a single transaction
2960     if ( my $data = $sth->fetchrow_hashref ) {
2961
2962         # save the record in deletedbiblio
2963         # find the fields to save
2964         my $query = "INSERT INTO deletedbiblio SET ";
2965         my @bind  = ();
2966         foreach my $temp ( keys %$data ) {
2967             $query .= "$temp = ?,";
2968             push( @bind, $data->{$temp} );
2969         }
2970
2971         # replace the last , by ",?)"
2972         $query =~ s/\,$//;
2973         my $bkup_sth = $dbh->prepare($query);
2974         $bkup_sth->execute(@bind);
2975         $bkup_sth->finish;
2976
2977         _koha_delete_biblio_metadata( $biblionumber );
2978
2979         # delete the biblio
2980         my $sth2 = $dbh->prepare("DELETE FROM biblio WHERE biblionumber=?");
2981         $sth2->execute($biblionumber);
2982         # update the timestamp (Bugzilla 7146)
2983         $sth2= $dbh->prepare("UPDATE deletedbiblio SET timestamp=NOW() WHERE biblionumber=?");
2984         $sth2->execute($biblionumber);
2985         $sth2->finish;
2986     }
2987     $sth->finish;
2988     return;
2989 }
2990
2991 =head2 _koha_delete_biblioitems
2992
2993   $error = _koha_delete_biblioitems($dbh,$biblioitemnumber);
2994
2995 Internal sub for deleting from biblioitems table -- also saves to deletedbiblioitems
2996
2997 C<$dbh> - the database handle
2998 C<$biblionumber> - the biblioitemnumber of the biblioitem to be deleted
2999
3000 =cut
3001
3002 # FIXME: add error handling
3003
3004 sub _koha_delete_biblioitems {
3005     my ( $dbh, $biblioitemnumber ) = @_;
3006
3007     # get all the data for this biblioitem
3008     my $sth = $dbh->prepare("SELECT * FROM biblioitems WHERE biblioitemnumber=?");
3009     $sth->execute($biblioitemnumber);
3010
3011     if ( my $data = $sth->fetchrow_hashref ) {
3012
3013         # save the record in deletedbiblioitems
3014         # find the fields to save
3015         my $query = "INSERT INTO deletedbiblioitems SET ";
3016         my @bind  = ();
3017         foreach my $temp ( keys %$data ) {
3018             $query .= "$temp = ?,";
3019             push( @bind, $data->{$temp} );
3020         }
3021
3022         # replace the last , by ",?)"
3023         $query =~ s/\,$//;
3024         my $bkup_sth = $dbh->prepare($query);
3025         $bkup_sth->execute(@bind);
3026         $bkup_sth->finish;
3027
3028         # delete the biblioitem
3029         my $sth2 = $dbh->prepare("DELETE FROM biblioitems WHERE biblioitemnumber=?");
3030         $sth2->execute($biblioitemnumber);
3031         # update the timestamp (Bugzilla 7146)
3032         $sth2= $dbh->prepare("UPDATE deletedbiblioitems SET timestamp=NOW() WHERE biblioitemnumber=?");
3033         $sth2->execute($biblioitemnumber);
3034         $sth2->finish;
3035     }
3036     $sth->finish;
3037     return;
3038 }
3039
3040 =head2 _koha_delete_biblio_metadata
3041
3042   $error = _koha_delete_biblio_metadata($biblionumber);
3043
3044 C<$biblionumber> - the biblionumber of the biblio metadata to be deleted
3045
3046 =cut
3047
3048 sub _koha_delete_biblio_metadata {
3049     my ($biblionumber) = @_;
3050
3051     my $dbh    = C4::Context->dbh;
3052     my $schema = Koha::Database->new->schema;
3053     $schema->txn_do(
3054         sub {
3055             $dbh->do( q|
3056                 INSERT INTO deletedbiblio_metadata (biblionumber, format, `schema`, metadata)
3057                 SELECT biblionumber, format, `schema`, metadata FROM biblio_metadata WHERE biblionumber=?
3058             |,  undef, $biblionumber );
3059             $dbh->do( q|DELETE FROM biblio_metadata WHERE biblionumber=?|,
3060                 undef, $biblionumber );
3061         }
3062     );
3063 }
3064
3065 =head1 UNEXPORTED FUNCTIONS
3066
3067 =head2 ModBiblioMarc
3068
3069   &ModBiblioMarc($newrec,$biblionumber,$frameworkcode);
3070
3071 Add MARC XML data for a biblio to koha
3072
3073 Function exported, but should NOT be used, unless you really know what you're doing
3074
3075 =cut
3076
3077 sub ModBiblioMarc {
3078     # pass the MARC::Record to this function, and it will create the records in
3079     # the marcxml field
3080     my ( $record, $biblionumber, $frameworkcode ) = @_;
3081     if ( !$record ) {
3082         carp 'ModBiblioMarc passed an undefined record';
3083         return;
3084     }
3085
3086     # Clone record as it gets modified
3087     $record = $record->clone();
3088     my $dbh    = C4::Context->dbh;
3089     my @fields = $record->fields();
3090     if ( !$frameworkcode ) {
3091         $frameworkcode = "";
3092     }
3093     my $sth = $dbh->prepare("UPDATE biblio SET frameworkcode=? WHERE biblionumber=?");
3094     $sth->execute( $frameworkcode, $biblionumber );
3095     $sth->finish;
3096     my $encoding = C4::Context->preference("marcflavour");
3097
3098     # deal with UNIMARC field 100 (encoding) : create it if needed & set encoding to unicode
3099     if ( $encoding eq "UNIMARC" ) {
3100         my $defaultlanguage = C4::Context->preference("UNIMARCField100Language");
3101         $defaultlanguage = "fre" if (!$defaultlanguage || length($defaultlanguage) != 3);
3102         my $string = $record->subfield( 100, "a" );
3103         if ( ($string) && ( length( $record->subfield( 100, "a" ) ) == 36 ) ) {
3104             my $f100 = $record->field(100);
3105             $record->delete_field($f100);
3106         } else {
3107             $string = POSIX::strftime( "%Y%m%d", localtime );
3108             $string =~ s/\-//g;
3109             $string = sprintf( "%-*s", 35, $string );
3110             substr ( $string, 22, 3, $defaultlanguage);
3111         }
3112         substr( $string, 25, 3, "y50" );
3113         unless ( $record->subfield( 100, "a" ) ) {
3114             $record->insert_fields_ordered( MARC::Field->new( 100, "", "", "a" => $string ) );
3115         }
3116     }
3117
3118     #enhancement 5374: update transaction date (005) for marc21/unimarc
3119     if($encoding =~ /MARC21|UNIMARC/) {
3120       my @a= (localtime) [5,4,3,2,1,0]; $a[0]+=1900; $a[1]++;
3121         # YY MM DD HH MM SS (update year and month)
3122       my $f005= $record->field('005');
3123       $f005->update(sprintf("%4d%02d%02d%02d%02d%04.1f",@a)) if $f005;
3124     }
3125
3126     my $metadata = {
3127         biblionumber => $biblionumber,
3128         format       => 'marcxml',
3129         schema       => C4::Context->preference('marcflavour'),
3130     };
3131     $record->as_usmarc; # Bug 20126/10455 This triggers field length calculation
3132
3133     my $m_rs = Koha::Biblio::Metadatas->find($metadata) //
3134         Koha::Biblio::Metadata->new($metadata);
3135
3136     my $userenv = C4::Context->userenv;
3137     if ($userenv) {
3138         my $borrowernumber = $userenv->{number};
3139         my $borrowername = join ' ', map { $_ // q{} } @$userenv{qw(firstname surname)};
3140         unless ($m_rs->in_storage) {
3141             Koha::Util::MARC::set_marc_field($record, C4::Context->preference('MarcFieldForCreatorId'), $borrowernumber);
3142             Koha::Util::MARC::set_marc_field($record, C4::Context->preference('MarcFieldForCreatorName'), $borrowername);
3143         }
3144         Koha::Util::MARC::set_marc_field($record, C4::Context->preference('MarcFieldForModifierId'), $borrowernumber);
3145         Koha::Util::MARC::set_marc_field($record, C4::Context->preference('MarcFieldForModifierName'), $borrowername);
3146     }
3147
3148     $m_rs->metadata( $record->as_xml_record($encoding) );
3149     $m_rs->store;
3150
3151     ModZebra( $biblionumber, "specialUpdate", "biblioserver" );
3152
3153     return $biblionumber;
3154 }
3155
3156 =head2 prepare_host_field
3157
3158 $marcfield = prepare_host_field( $hostbiblioitem, $marcflavour );
3159 Generate the host item entry for an analytic child entry
3160
3161 =cut
3162
3163 sub prepare_host_field {
3164     my ( $hostbiblio, $marcflavour ) = @_;
3165     $marcflavour ||= C4::Context->preference('marcflavour');
3166     my $host = GetMarcBiblio({ biblionumber => $hostbiblio });
3167     # unfortunately as_string does not 'do the right thing'
3168     # if field returns undef
3169     my %sfd;
3170     my $field;
3171     my $host_field;
3172     if ( $marcflavour eq 'MARC21' || $marcflavour eq 'NORMARC' ) {
3173         if ( $field = $host->field('100') || $host->field('110') || $host->field('11') ) {
3174             my $s = $field->as_string('ab');
3175             if ($s) {
3176                 $sfd{a} = $s;
3177             }
3178         }
3179         if ( $field = $host->field('245') ) {
3180             my $s = $field->as_string('a');
3181             if ($s) {
3182                 $sfd{t} = $s;
3183             }
3184         }
3185         if ( $field = $host->field('260') ) {
3186             my $s = $field->as_string('abc');
3187             if ($s) {
3188                 $sfd{d} = $s;
3189             }
3190         }
3191         if ( $field = $host->field('240') ) {
3192             my $s = $field->as_string();
3193             if ($s) {
3194                 $sfd{b} = $s;
3195             }
3196         }
3197         if ( $field = $host->field('022') ) {
3198             my $s = $field->as_string('a');
3199             if ($s) {
3200                 $sfd{x} = $s;
3201             }
3202         }
3203         if ( $field = $host->field('020') ) {
3204             my $s = $field->as_string('a');
3205             if ($s) {
3206                 $sfd{z} = $s;
3207             }
3208         }
3209         if ( $field = $host->field('001') ) {
3210             $sfd{w} = $field->data(),;
3211         }
3212         $host_field = MARC::Field->new( 773, '0', ' ', %sfd );
3213         return $host_field;
3214     }
3215     elsif ( $marcflavour eq 'UNIMARC' ) {
3216         #author
3217         if ( $field = $host->field('700') || $host->field('710') || $host->field('720') ) {
3218             my $s = $field->as_string('ab');
3219             if ($s) {
3220                 $sfd{a} = $s;
3221             }
3222         }
3223         #title
3224         if ( $field = $host->field('200') ) {
3225             my $s = $field->as_string('a');
3226             if ($s) {
3227                 $sfd{t} = $s;
3228             }
3229         }
3230         #place of publicaton
3231         if ( $field = $host->field('210') ) {
3232             my $s = $field->as_string('a');
3233             if ($s) {
3234                 $sfd{c} = $s;
3235             }
3236         }
3237         #date of publication
3238         if ( $field = $host->field('210') ) {
3239             my $s = $field->as_string('d');
3240             if ($s) {
3241                 $sfd{d} = $s;
3242             }
3243         }
3244         #edition statement
3245         if ( $field = $host->field('205') ) {
3246             my $s = $field->as_string();
3247             if ($s) {
3248                 $sfd{e} = $s;
3249             }
3250         }
3251         #URL
3252         if ( $field = $host->field('856') ) {
3253             my $s = $field->as_string('u');
3254             if ($s) {
3255                 $sfd{u} = $s;
3256             }
3257         }
3258         #ISSN
3259         if ( $field = $host->field('011') ) {
3260             my $s = $field->as_string('a');
3261             if ($s) {
3262                 $sfd{x} = $s;
3263             }
3264         }
3265         #ISBN
3266         if ( $field = $host->field('010') ) {
3267             my $s = $field->as_string('a');
3268             if ($s) {
3269                 $sfd{y} = $s;
3270             }
3271         }
3272         if ( $field = $host->field('001') ) {
3273             $sfd{0} = $field->data(),;
3274         }
3275         $host_field = MARC::Field->new( 461, '0', ' ', %sfd );
3276         return $host_field;
3277     }
3278     return;
3279 }
3280
3281
3282 =head2 UpdateTotalIssues
3283
3284   UpdateTotalIssues($biblionumber, $increase, [$value])
3285
3286 Update the total issue count for a particular bib record.
3287
3288 =over 4
3289
3290 =item C<$biblionumber> is the biblionumber of the bib to update
3291
3292 =item C<$increase> is the amount to increase (or decrease) the total issues count by
3293
3294 =item C<$value> is the absolute value that total issues count should be set to. If provided, C<$increase> is ignored.
3295
3296 =back
3297
3298 =cut
3299
3300 sub UpdateTotalIssues {
3301     my ($biblionumber, $increase, $value) = @_;
3302     my $totalissues;
3303
3304     my $record = GetMarcBiblio({ biblionumber => $biblionumber });
3305     unless ($record) {
3306         carp "UpdateTotalIssues could not get biblio record";
3307         return;
3308     }
3309     my $biblio = Koha::Biblios->find( $biblionumber );
3310     unless ($biblio) {
3311         carp "UpdateTotalIssues could not get datas of biblio";
3312         return;
3313     }
3314     my $biblioitem = $biblio->biblioitem;
3315     my ($totalissuestag, $totalissuessubfield) = GetMarcFromKohaField( 'biblioitems.totalissues' );
3316     unless ($totalissuestag) {
3317         return 1; # There is nothing to do
3318     }
3319
3320     if (defined $value) {
3321         $totalissues = $value;
3322     } else {
3323         $totalissues = $biblioitem->totalissues + $increase;
3324     }
3325
3326      my $field = $record->field($totalissuestag);
3327      if (defined $field) {
3328          $field->update( $totalissuessubfield => $totalissues );
3329      } else {
3330          $field = MARC::Field->new($totalissuestag, '0', '0',
3331                  $totalissuessubfield => $totalissues);
3332          $record->insert_grouped_field($field);
3333      }
3334
3335      return ModBiblio($record, $biblionumber, $biblio->frameworkcode);
3336 }
3337
3338 =head2 RemoveAllNsb
3339
3340     &RemoveAllNsb($record);
3341
3342 Removes all nsb/nse chars from a record
3343
3344 =cut
3345
3346 sub RemoveAllNsb {
3347     my $record = shift;
3348     if (!$record) {
3349         carp 'RemoveAllNsb called with undefined record';
3350         return;
3351     }
3352
3353     SetUTF8Flag($record);
3354
3355     foreach my $field ($record->fields()) {
3356         if ($field->is_control_field()) {
3357             $field->update(nsb_clean($field->data()));
3358         } else {
3359             my @subfields = $field->subfields();
3360             my @new_subfields;
3361             foreach my $subfield (@subfields) {
3362                 push @new_subfields, $subfield->[0] => nsb_clean($subfield->[1]);
3363             }
3364             if (scalar(@new_subfields) > 0) {
3365                 my $new_field;
3366                 eval {
3367                     $new_field = MARC::Field->new(
3368                         $field->tag(),
3369                         $field->indicator(1),
3370                         $field->indicator(2),
3371                         @new_subfields
3372                     );
3373                 };
3374                 if ($@) {
3375                     warn "error in RemoveAllNsb : $@";
3376                 } else {
3377                     $field->replace_with($new_field);
3378                 }
3379             }
3380         }
3381     }
3382
3383     return $record;
3384 }
3385
3386 1;
3387
3388
3389 =head2 _after_biblio_action_hooks
3390
3391 Helper method that takes care of calling all plugin hooks
3392
3393 =cut
3394
3395 sub _after_biblio_action_hooks {
3396     my ( $args ) = @_;
3397
3398     my $biblio_id = $args->{biblio_id};
3399     my $action    = $args->{action};
3400
3401     my $biblio = Koha::Biblios->find( $biblio_id );
3402     Koha::Plugins->call(
3403         'after_biblio_action',
3404         {
3405             action    => $action,
3406             biblio    => $biblio,
3407             biblio_id => $biblio_id,
3408         }
3409     );
3410 }
3411
3412 __END__
3413
3414 =head1 AUTHOR
3415
3416 Koha Development Team <http://koha-community.org/>
3417
3418 Paul POULAIN paul.poulain@free.fr
3419
3420 Joshua Ferraro jmf@liblime.com
3421
3422 =cut