C4/Biblio.pm

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