C4/Biblio.pm

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