C4/Biblio.pm

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