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