C4/Biblio.pm

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