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