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