C4/Biblio.pm

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