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 field 555 gets special attention for the $u subfields.
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' && $tag =~ /555/ ) {
1732             # Field 555$u contains URLs
1733             # We first push the regular subfields and all $u's separately
1734             # Leave further actions to the template
1735             push @marcnotes, { marcnote => $field->as_string('abcd') };
1736             foreach my $sub ( $field->subfield('u') ) {
1737                 push @marcnotes, { marcnote => $sub };
1738             }
1739         } else {
1740             push @marcnotes, { marcnote => $field->as_string() };
1741         }
1742     }
1743     return \@marcnotes;
1744 }
1745
1746 =head2 GetMarcSubjects
1747
1748   $marcsubjcts = GetMarcSubjects($record,$marcflavour);
1749
1750 Get all subjects from the MARC record and returns them in an array.
1751 The subjects are stored in different fields depending on MARC flavour
1752
1753 =cut
1754
1755 sub GetMarcSubjects {
1756     my ( $record, $marcflavour ) = @_;
1757     if (!$record) {
1758         carp 'GetMarcSubjects called on undefined record';
1759         return;
1760     }
1761     my ( $mintag, $maxtag, $fields_filter );
1762     if ( $marcflavour eq "UNIMARC" ) {
1763         $mintag = "600";
1764         $maxtag = "611";
1765         $fields_filter = '6..';
1766     } else { # marc21/normarc
1767         $mintag = "600";
1768         $maxtag = "699";
1769         $fields_filter = '6..';
1770     }
1771
1772     my @marcsubjects;
1773
1774     my $subject_limit = C4::Context->preference("TraceCompleteSubfields") ? 'su,complete-subfield' : 'su';
1775     my $AuthoritySeparator = C4::Context->preference('AuthoritySeparator');
1776
1777     foreach my $field ( $record->field($fields_filter) ) {
1778         next unless ($field->tag() >= $mintag && $field->tag() <= $maxtag);
1779         my @subfields_loop;
1780         my @subfields = $field->subfields();
1781         my @link_loop;
1782
1783         # if there is an authority link, build the links with an= subfield9
1784         my $subfield9 = $field->subfield('9');
1785         my $authoritylink;
1786         if ($subfield9) {
1787             my $linkvalue = $subfield9;
1788             $linkvalue =~ s/(\(|\))//g;
1789             @link_loop = ( { limit => 'an', 'link' => $linkvalue } );
1790             $authoritylink = $linkvalue
1791         }
1792
1793         # other subfields
1794         for my $subject_subfield (@subfields) {
1795             next if ( $subject_subfield->[0] eq '9' );
1796
1797             # don't load unimarc subfields 3,4,5
1798             next if ( ( $marcflavour eq "UNIMARC" ) and ( $subject_subfield->[0] =~ /2|3|4|5/ ) );
1799             # don't load MARC21 subfields 2 (FIXME: any more subfields??)
1800             next if ( ( $marcflavour eq "MARC21" ) and ( $subject_subfield->[0] =~ /2/ ) );
1801
1802             my $code      = $subject_subfield->[0];
1803             my $value     = $subject_subfield->[1];
1804             my $linkvalue = $value;
1805             $linkvalue =~ s/(\(|\))//g;
1806             # if no authority link, build a search query
1807             unless ($subfield9) {
1808                 push @link_loop, {
1809                     limit    => $subject_limit,
1810                     'link'   => $linkvalue,
1811                     operator => (scalar @link_loop) ? ' and ' : undef
1812                 };
1813             }
1814             my @this_link_loop = @link_loop;
1815             # do not display $0
1816             unless ( $code eq '0' ) {
1817                 push @subfields_loop, {
1818                     code      => $code,
1819                     value     => $value,
1820                     link_loop => \@this_link_loop,
1821                     separator => (scalar @subfields_loop) ? $AuthoritySeparator : ''
1822                 };
1823             }
1824         }
1825
1826         push @marcsubjects, {
1827             MARCSUBJECT_SUBFIELDS_LOOP => \@subfields_loop,
1828             authoritylink => $authoritylink,
1829         } if $authoritylink || @subfields_loop;
1830
1831     }
1832     return \@marcsubjects;
1833 }    #end getMARCsubjects
1834
1835 =head2 GetMarcAuthors
1836
1837   authors = GetMarcAuthors($record,$marcflavour);
1838
1839 Get all authors from the MARC record and returns them in an array.
1840 The authors are stored in different fields depending on MARC flavour
1841
1842 =cut
1843
1844 sub GetMarcAuthors {
1845     my ( $record, $marcflavour ) = @_;
1846     if (!$record) {
1847         carp 'GetMarcAuthors called on undefined record';
1848         return;
1849     }
1850     my ( $mintag, $maxtag, $fields_filter );
1851
1852     # tagslib useful only for UNIMARC author responsibilities
1853     my $tagslib;
1854     if ( $marcflavour eq "UNIMARC" ) {
1855         # FIXME : we don't have the framework available, we take the default framework. May be buggy on some setups, will be usually correct.
1856         $tagslib = GetMarcStructure( 1, '', { unsafe => 1 });
1857         $mintag = "700";
1858         $maxtag = "712";
1859         $fields_filter = '7..';
1860     } else { # marc21/normarc
1861         $mintag = "700";
1862         $maxtag = "720";
1863         $fields_filter = '7..';
1864     }
1865
1866     my @marcauthors;
1867     my $AuthoritySeparator = C4::Context->preference('AuthoritySeparator');
1868
1869     foreach my $field ( $record->field($fields_filter) ) {
1870         next unless $field->tag() >= $mintag && $field->tag() <= $maxtag;
1871         my @subfields_loop;
1872         my @link_loop;
1873         my @subfields  = $field->subfields();
1874         my $count_auth = 0;
1875
1876         # if there is an authority link, build the link with Koha-Auth-Number: subfield9
1877         my $subfield9 = $field->subfield('9');
1878         if ($subfield9) {
1879             my $linkvalue = $subfield9;
1880             $linkvalue =~ s/(\(|\))//g;
1881             @link_loop = ( { 'limit' => 'an', 'link' => $linkvalue } );
1882         }
1883
1884         # other subfields
1885         my $unimarc3;
1886         for my $authors_subfield (@subfields) {
1887             next if ( $authors_subfield->[0] eq '9' );
1888
1889             # unimarc3 contains the $3 of the author for UNIMARC.
1890             # For french academic libraries, it's the "ppn", and it's required for idref webservice
1891             $unimarc3 = $authors_subfield->[1] if $marcflavour eq 'UNIMARC' and $authors_subfield->[0] =~ /3/;
1892
1893             # don't load unimarc subfields 3, 5
1894             next if ( $marcflavour eq 'UNIMARC' and ( $authors_subfield->[0] =~ /3|5/ ) );
1895
1896             my $code = $authors_subfield->[0];
1897             my $value        = $authors_subfield->[1];
1898             my $linkvalue    = $value;
1899             $linkvalue =~ s/(\(|\))//g;
1900             # UNIMARC author responsibility
1901             if ( $marcflavour eq 'UNIMARC' and $code eq '4' ) {
1902                 $value = GetAuthorisedValueDesc( $field->tag(), $code, $value, '', $tagslib );
1903                 $linkvalue = "($value)";
1904             }
1905             # if no authority link, build a search query
1906             unless ($subfield9) {
1907                 push @link_loop, {
1908                     limit    => 'au',
1909                     'link'   => $linkvalue,
1910                     operator => (scalar @link_loop) ? ' and ' : undef
1911                 };
1912             }
1913             my @this_link_loop = @link_loop;
1914             # do not display $0
1915             unless ( $code eq '0') {
1916                 push @subfields_loop, {
1917                     tag       => $field->tag(),
1918                     code      => $code,
1919                     value     => $value,
1920                     link_loop => \@this_link_loop,
1921                     separator => (scalar @subfields_loop) ? $AuthoritySeparator : ''
1922                 };
1923             }
1924         }
1925         push @marcauthors, {
1926             MARCAUTHOR_SUBFIELDS_LOOP => \@subfields_loop,
1927             authoritylink => $subfield9,
1928             unimarc3 => $unimarc3
1929         };
1930     }
1931     return \@marcauthors;
1932 }
1933
1934 =head2 GetMarcUrls
1935
1936   $marcurls = GetMarcUrls($record,$marcflavour);
1937
1938 Returns arrayref of URLs from MARC data, suitable to pass to tmpl loop.
1939 Assumes web resources (not uncommon in MARC21 to omit resource type ind)
1940
1941 =cut
1942
1943 sub GetMarcUrls {
1944     my ( $record, $marcflavour ) = @_;
1945     if (!$record) {
1946         carp 'GetMarcUrls called on undefined record';
1947         return;
1948     }
1949
1950     my @marcurls;
1951     for my $field ( $record->field('856') ) {
1952         my @notes;
1953         for my $note ( $field->subfield('z') ) {
1954             push @notes, { note => $note };
1955         }
1956         my @urls = $field->subfield('u');
1957         foreach my $url (@urls) {
1958             $url =~ s/^\s+|\s+$//g; # trim
1959             my $marcurl;
1960             if ( $marcflavour eq 'MARC21' ) {
1961                 my $s3   = $field->subfield('3');
1962                 my $link = $field->subfield('y');
1963                 unless ( $url =~ /^\w+:/ ) {
1964                     if ( $field->indicator(1) eq '7' ) {
1965                         $url = $field->subfield('2') . "://" . $url;
1966                     } elsif ( $field->indicator(1) eq '1' ) {
1967                         $url = 'ftp://' . $url;
1968                     } else {
1969
1970                         #  properly, this should be if ind1=4,
1971                         #  however we will assume http protocol since we're building a link.
1972                         $url = 'http://' . $url;
1973                     }
1974                 }
1975
1976                 # TODO handle ind 2 (relationship)
1977                 $marcurl = {
1978                     MARCURL => $url,
1979                     notes   => \@notes,
1980                 };
1981                 $marcurl->{'linktext'} = $link || $s3 || C4::Context->preference('URLLinkText') || $url;
1982                 $marcurl->{'part'} = $s3 if ($link);
1983                 $marcurl->{'toc'} = 1 if ( defined($s3) && $s3 =~ /^[Tt]able/ );
1984             } else {
1985                 $marcurl->{'linktext'} = $field->subfield('2') || C4::Context->preference('URLLinkText') || $url;
1986                 $marcurl->{'MARCURL'} = $url;
1987             }
1988             push @marcurls, $marcurl;
1989         }
1990     }
1991     return \@marcurls;
1992 }
1993
1994 =head2 GetMarcSeries
1995
1996   $marcseriesarray = GetMarcSeries($record,$marcflavour);
1997
1998 Get all series from the MARC record and returns them in an array.
1999 The series are stored in different fields depending on MARC flavour
2000
2001 =cut
2002
2003 sub GetMarcSeries {
2004     my ( $record, $marcflavour ) = @_;
2005     if (!$record) {
2006         carp 'GetMarcSeries called on undefined record';
2007         return;
2008     }
2009
2010     my ( $mintag, $maxtag, $fields_filter );
2011     if ( $marcflavour eq "UNIMARC" ) {
2012         $mintag = "225";
2013         $maxtag = "225";
2014         $fields_filter = '2..';
2015     } else {    # marc21/normarc
2016         $mintag = "440";
2017         $maxtag = "490";
2018         $fields_filter = '4..';
2019     }
2020
2021     my @marcseries;
2022     my $AuthoritySeparator = C4::Context->preference('AuthoritySeparator');
2023
2024     foreach my $field ( $record->field($fields_filter) ) {
2025         next unless $field->tag() >= $mintag && $field->tag() <= $maxtag;
2026         my @subfields_loop;
2027         my @subfields = $field->subfields();
2028         my @link_loop;
2029
2030         for my $series_subfield (@subfields) {
2031
2032             # ignore $9, used for authority link
2033             next if ( $series_subfield->[0] eq '9' );
2034
2035             my $volume_number;
2036             my $code      = $series_subfield->[0];
2037             my $value     = $series_subfield->[1];
2038             my $linkvalue = $value;
2039             $linkvalue =~ s/(\(|\))//g;
2040
2041             # see if this is an instance of a volume
2042             if ( $code eq 'v' ) {
2043                 $volume_number = 1;
2044             }
2045
2046             push @link_loop, {
2047                 'link' => $linkvalue,
2048                 operator => (scalar @link_loop) ? ' and ' : undef
2049             };
2050
2051             if ($volume_number) {
2052                 push @subfields_loop, { volumenum => $value };
2053             } else {
2054                 push @subfields_loop, {
2055                     code      => $code,
2056                     value     => $value,
2057                     link_loop => \@link_loop,
2058                     separator => (scalar @subfields_loop) ? $AuthoritySeparator : '',
2059                     volumenum => $volume_number,
2060                 }
2061             }
2062         }
2063         push @marcseries, { MARCSERIES_SUBFIELDS_LOOP => \@subfields_loop };
2064
2065     }
2066     return \@marcseries;
2067 }    #end getMARCseriess
2068
2069 =head2 GetMarcHosts
2070
2071   $marchostsarray = GetMarcHosts($record,$marcflavour);
2072
2073 Get all host records (773s MARC21, 461 UNIMARC) from the MARC record and returns them in an array.
2074
2075 =cut
2076
2077 sub GetMarcHosts {
2078     my ( $record, $marcflavour ) = @_;
2079     if (!$record) {
2080         carp 'GetMarcHosts called on undefined record';
2081         return;
2082     }
2083
2084     my ( $tag,$title_subf,$bibnumber_subf,$itemnumber_subf);
2085     $marcflavour ||="MARC21";
2086     if ( $marcflavour eq "MARC21" || $marcflavour eq "NORMARC" ) {
2087         $tag = "773";
2088         $title_subf = "t";
2089         $bibnumber_subf ="0";
2090         $itemnumber_subf='9';
2091     }
2092     elsif ($marcflavour eq "UNIMARC") {
2093         $tag = "461";
2094         $title_subf = "t";
2095         $bibnumber_subf ="0";
2096         $itemnumber_subf='9';
2097     };
2098
2099     my @marchosts;
2100
2101     foreach my $field ( $record->field($tag)) {
2102
2103         my @fields_loop;
2104
2105         my $hostbiblionumber = $field->subfield("$bibnumber_subf");
2106         my $hosttitle = $field->subfield($title_subf);
2107         my $hostitemnumber=$field->subfield($itemnumber_subf);
2108         push @fields_loop, { hostbiblionumber => $hostbiblionumber, hosttitle => $hosttitle, hostitemnumber => $hostitemnumber};
2109         push @marchosts, { MARCHOSTS_FIELDS_LOOP => \@fields_loop };
2110
2111         }
2112     my $marchostsarray = \@marchosts;
2113     return $marchostsarray;
2114 }
2115
2116 =head2 UpsertMarcSubfield
2117
2118     my $record = C4::Biblio::UpsertMarcSubfield($MARC::Record, $fieldTag, $subfieldCode, $subfieldContent);
2119
2120 =cut
2121
2122 sub UpsertMarcSubfield {
2123     my ($record, $tag, $code, $content) = @_;
2124     my $f = $record->field($tag);
2125
2126     if ($f) {
2127         $f->update( $code => $content );
2128     }
2129     else {
2130         my $f = MARC::Field->new( $tag, '', '', $code => $content);
2131         $record->insert_fields_ordered( $f );
2132     }
2133 }
2134
2135 =head2 UpsertMarcControlField
2136
2137     my $record = C4::Biblio::UpsertMarcControlField($MARC::Record, $fieldTag, $content);
2138
2139 =cut
2140
2141 sub UpsertMarcControlField {
2142     my ($record, $tag, $content) = @_;
2143     die "UpsertMarcControlField() \$tag '$tag' is not a control field\n" unless 0+$tag < 10;
2144     my $f = $record->field($tag);
2145
2146     if ($f) {
2147         $f->update( $content );
2148     }
2149     else {
2150         my $f = MARC::Field->new($tag, $content);
2151         $record->insert_fields_ordered( $f );
2152     }
2153 }
2154
2155 =head2 GetFrameworkCode
2156
2157   $frameworkcode = GetFrameworkCode( $biblionumber )
2158
2159 =cut
2160
2161 sub GetFrameworkCode {
2162     my ($biblionumber) = @_;
2163     my $dbh            = C4::Context->dbh;
2164     my $sth            = $dbh->prepare("SELECT frameworkcode FROM biblio WHERE biblionumber=?");
2165     $sth->execute($biblionumber);
2166     my ($frameworkcode) = $sth->fetchrow;
2167     return $frameworkcode;
2168 }
2169
2170 =head2 TransformKohaToMarc
2171
2172     $record = TransformKohaToMarc( $hash [, $params ]  )
2173
2174 This function builds a (partial) MARC::Record from a hash.
2175 Hash entries can be from biblio, biblioitems or items.
2176 The params hash includes the parameter no_split used in C4::Items.
2177
2178 This function is called in acquisition module, to create a basic catalogue
2179 entry from user entry.
2180
2181 =cut
2182
2183
2184 sub TransformKohaToMarc {
2185     my ( $hash, $params ) = @_;
2186     my $record = MARC::Record->new();
2187     SetMarcUnicodeFlag( $record, C4::Context->preference("marcflavour") );
2188
2189     # In the next call we use the Default framework, since it is considered
2190     # authoritative for Koha to Marc mappings.
2191     my $mss = GetMarcSubfieldStructure( '' ); # do not change framework
2192     my $tag_hr = {};
2193     while ( my ($kohafield, $value) = each %$hash ) {
2194         foreach my $fld ( @{ $mss->{$kohafield} } ) {
2195             my $tagfield    = $fld->{tagfield};
2196             my $tagsubfield = $fld->{tagsubfield};
2197             next if !$tagfield;
2198             my @values = $params->{no_split}
2199                 ? ( $value )
2200                 : split(/\s?\|\s?/, $value, -1);
2201             foreach my $value ( @values ) {
2202                 next if $value eq '';
2203                 $tag_hr->{$tagfield} //= [];
2204                 push @{$tag_hr->{$tagfield}}, [($tagsubfield, $value)];
2205             }
2206         }
2207     }
2208     foreach my $tag (sort keys %$tag_hr) {
2209         my @sfl = @{$tag_hr->{$tag}};
2210         @sfl = sort { $a->[0] cmp $b->[0]; } @sfl;
2211         @sfl = map { @{$_}; } @sfl;
2212         # Special care for control fields: remove the subfield indication @
2213         # and do not insert indicators.
2214         my @ind = $tag < 10 ? () : ( " ", " " );
2215         @sfl = grep { $_ ne '@' } @sfl if $tag < 10;
2216         $record->insert_fields_ordered( MARC::Field->new($tag, @ind, @sfl) );
2217     }
2218     return $record;
2219 }
2220
2221 =head2 PrepHostMarcField
2222
2223     $hostfield = PrepHostMarcField ( $hostbiblionumber,$hostitemnumber,$marcflavour )
2224
2225 This function returns a host field populated with data from the host record, the field can then be added to an analytical record
2226
2227 =cut
2228
2229 sub PrepHostMarcField {
2230     my ($hostbiblionumber,$hostitemnumber, $marcflavour) = @_;
2231     $marcflavour ||="MARC21";
2232
2233     require C4::Items;
2234     my $hostrecord = GetMarcBiblio({ biblionumber => $hostbiblionumber });
2235         my $item = C4::Items::GetItem($hostitemnumber);
2236
2237         my $hostmarcfield;
2238     if ( $marcflavour eq "MARC21" || $marcflavour eq "NORMARC" ) {
2239
2240         #main entry
2241         my $mainentry;
2242         if ($hostrecord->subfield('100','a')){
2243             $mainentry = $hostrecord->subfield('100','a');
2244         } elsif ($hostrecord->subfield('110','a')){
2245             $mainentry = $hostrecord->subfield('110','a');
2246         } else {
2247             $mainentry = $hostrecord->subfield('111','a');
2248         }
2249
2250         # qualification info
2251         my $qualinfo;
2252         if (my $field260 = $hostrecord->field('260')){
2253             $qualinfo =  $field260->as_string( 'abc' );
2254         }
2255
2256
2257         #other fields
2258         my $ed = $hostrecord->subfield('250','a');
2259         my $barcode = $item->{'barcode'};
2260         my $title = $hostrecord->subfield('245','a');
2261
2262         # record control number, 001 with 003 and prefix
2263         my $recctrlno;
2264         if ($hostrecord->field('001')){
2265             $recctrlno = $hostrecord->field('001')->data();
2266             if ($hostrecord->field('003')){
2267                 $recctrlno = '('.$hostrecord->field('003')->data().')'.$recctrlno;
2268             }
2269         }
2270
2271         # issn/isbn
2272         my $issn = $hostrecord->subfield('022','a');
2273         my $isbn = $hostrecord->subfield('020','a');
2274
2275
2276         $hostmarcfield = MARC::Field->new(
2277                 773, '0', '',
2278                 '0' => $hostbiblionumber,
2279                 '9' => $hostitemnumber,
2280                 'a' => $mainentry,
2281                 'b' => $ed,
2282                 'd' => $qualinfo,
2283                 'o' => $barcode,
2284                 't' => $title,
2285                 'w' => $recctrlno,
2286                 'x' => $issn,
2287                 'z' => $isbn
2288                 );
2289     } elsif ($marcflavour eq "UNIMARC") {
2290         $hostmarcfield = MARC::Field->new(
2291             461, '', '',
2292             '0' => $hostbiblionumber,
2293             't' => $hostrecord->subfield('200','a'),
2294             '9' => $hostitemnumber
2295         );
2296     };
2297
2298     return $hostmarcfield;
2299 }
2300
2301 =head2 TransformHtmlToXml
2302
2303   $xml = TransformHtmlToXml( $tags, $subfields, $values, $indicator,
2304                              $ind_tag, $auth_type )
2305
2306 $auth_type contains :
2307
2308 =over
2309
2310 =item - nothing : rebuild a biblio. In UNIMARC the encoding is in 100$a pos 26/27
2311
2312 =item - UNIMARCAUTH : rebuild an authority. In UNIMARC, the encoding is in 100$a pos 13/14
2313
2314 =item - ITEM : rebuild an item : in UNIMARC, 100$a, it's in the biblio ! (otherwise, we would get 2 100 fields !)
2315
2316 =back
2317
2318 =cut
2319
2320 sub TransformHtmlToXml {
2321     my ( $tags, $subfields, $values, $indicator, $ind_tag, $auth_type ) = @_;
2322     # NOTE: The parameter $ind_tag is NOT USED -- BZ 11247
2323
2324     my $xml = MARC::File::XML::header('UTF-8');
2325     $xml .= "<record>\n";
2326     $auth_type = C4::Context->preference('marcflavour') unless $auth_type;
2327     MARC::File::XML->default_record_format($auth_type);
2328
2329     # in UNIMARC, field 100 contains the encoding
2330     # check that there is one, otherwise the
2331     # MARC::Record->new_from_xml will fail (and Koha will die)
2332     my $unimarc_and_100_exist = 0;
2333     $unimarc_and_100_exist = 1 if $auth_type eq 'ITEM';    # if we rebuild an item, no need of a 100 field
2334     my $prevvalue;
2335     my $prevtag = -1;
2336     my $first   = 1;
2337     my $j       = -1;
2338     for ( my $i = 0 ; $i < @$tags ; $i++ ) {
2339
2340         if ( C4::Context->preference('marcflavour') eq 'UNIMARC' and @$tags[$i] eq "100" and @$subfields[$i] eq "a" ) {
2341
2342             # if we have a 100 field and it's values are not correct, skip them.
2343             # if we don't have any valid 100 field, we will create a default one at the end
2344             my $enc = substr( @$values[$i], 26, 2 );
2345             if ( $enc eq '01' or $enc eq '50' or $enc eq '03' ) {
2346                 $unimarc_and_100_exist = 1;
2347             } else {
2348                 next;
2349             }
2350         }
2351         @$values[$i] =~ s/&/&amp;/g;
2352         @$values[$i] =~ s/</&lt;/g;
2353         @$values[$i] =~ s/>/&gt;/g;
2354         @$values[$i] =~ s/"/&quot;/g;
2355         @$values[$i] =~ s/'/&apos;/g;
2356
2357         if ( ( @$tags[$i] ne $prevtag ) ) {
2358             $j++ unless ( @$tags[$i] eq "" );
2359             my $indicator1 = eval { substr( @$indicator[$j], 0, 1 ) };
2360             my $indicator2 = eval { substr( @$indicator[$j], 1, 1 ) };
2361             my $ind1       = _default_ind_to_space($indicator1);
2362             my $ind2;
2363             if ( @$indicator[$j] ) {
2364                 $ind2 = _default_ind_to_space($indicator2);
2365             } else {
2366                 warn "Indicator in @$tags[$i] is empty";
2367                 $ind2 = " ";
2368             }
2369             if ( !$first ) {
2370                 $xml .= "</datafield>\n";
2371                 if (   ( @$tags[$i] && @$tags[$i] > 10 )
2372                     && ( @$values[$i] ne "" ) ) {
2373                     $xml .= "<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
2374                     $xml .= "<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
2375                     $first = 0;
2376                 } else {
2377                     $first = 1;
2378                 }
2379             } else {
2380                 if ( @$values[$i] ne "" ) {
2381
2382                     # leader
2383                     if ( @$tags[$i] eq "000" ) {
2384                         $xml .= "<leader>@$values[$i]</leader>\n";
2385                         $first = 1;
2386
2387                         # rest of the fixed fields
2388                     } elsif ( @$tags[$i] < 10 ) {
2389                         $xml .= "<controlfield tag=\"@$tags[$i]\">@$values[$i]</controlfield>\n";
2390                         $first = 1;
2391                     } else {
2392                         $xml .= "<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
2393                         $xml .= "<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
2394                         $first = 0;
2395                     }
2396                 }
2397             }
2398         } else {    # @$tags[$i] eq $prevtag
2399             my $indicator1 = eval { substr( @$indicator[$j], 0, 1 ) };
2400             my $indicator2 = eval { substr( @$indicator[$j], 1, 1 ) };
2401             my $ind1       = _default_ind_to_space($indicator1);
2402             my $ind2;
2403             if ( @$indicator[$j] ) {
2404                 $ind2 = _default_ind_to_space($indicator2);
2405             } else {
2406                 warn "Indicator in @$tags[$i] is empty";
2407                 $ind2 = " ";
2408             }
2409             if ( @$values[$i] eq "" ) {
2410             } else {
2411                 if ($first) {
2412                     $xml .= "<datafield tag=\"@$tags[$i]\" ind1=\"$ind1\" ind2=\"$ind2\">\n";
2413                     $first = 0;
2414                 }
2415                 $xml .= "<subfield code=\"@$subfields[$i]\">@$values[$i]</subfield>\n";
2416             }
2417         }
2418         $prevtag = @$tags[$i];
2419     }
2420     $xml .= "</datafield>\n" if $xml =~ m/<datafield/;
2421     if ( C4::Context->preference('marcflavour') eq 'UNIMARC' and !$unimarc_and_100_exist ) {
2422
2423         #     warn "SETTING 100 for $auth_type";
2424         my $string = strftime( "%Y%m%d", localtime(time) );
2425
2426         # set 50 to position 26 is biblios, 13 if authorities
2427         my $pos = 26;
2428         $pos = 13 if $auth_type eq 'UNIMARCAUTH';
2429         $string = sprintf( "%-*s", 35, $string );
2430         substr( $string, $pos, 6, "50" );
2431         $xml .= "<datafield tag=\"100\" ind1=\"\" ind2=\"\">\n";
2432         $xml .= "<subfield code=\"a\">$string</subfield>\n";
2433         $xml .= "</datafield>\n";
2434     }
2435     $xml .= "</record>\n";
2436     $xml .= MARC::File::XML::footer();
2437     return $xml;
2438 }
2439
2440 =head2 _default_ind_to_space
2441
2442 Passed what should be an indicator returns a space
2443 if its undefined or zero length
2444
2445 =cut
2446
2447 sub _default_ind_to_space {
2448     my $s = shift;
2449     if ( !defined $s || $s eq q{} ) {
2450         return ' ';
2451     }
2452     return $s;
2453 }
2454
2455 =head2 TransformHtmlToMarc
2456
2457     L<$record> = TransformHtmlToMarc(L<$cgi>)
2458     L<$cgi> is the CGI object which contains the values for subfields
2459     {
2460         'tag_010_indicator1_531951' ,
2461         'tag_010_indicator2_531951' ,
2462         'tag_010_code_a_531951_145735' ,
2463         'tag_010_subfield_a_531951_145735' ,
2464         'tag_200_indicator1_873510' ,
2465         'tag_200_indicator2_873510' ,
2466         'tag_200_code_a_873510_673465' ,
2467         'tag_200_subfield_a_873510_673465' ,
2468         'tag_200_code_b_873510_704318' ,
2469         'tag_200_subfield_b_873510_704318' ,
2470         'tag_200_code_e_873510_280822' ,
2471         'tag_200_subfield_e_873510_280822' ,
2472         'tag_200_code_f_873510_110730' ,
2473         'tag_200_subfield_f_873510_110730' ,
2474     }
2475     L<$record> is the MARC::Record object.
2476
2477 =cut
2478
2479 sub TransformHtmlToMarc {
2480     my ($cgi, $isbiblio) = @_;
2481
2482     my @params = $cgi->multi_param();
2483
2484     # explicitly turn on the UTF-8 flag for all
2485     # 'tag_' parameters to avoid incorrect character
2486     # conversion later on
2487     my $cgi_params = $cgi->Vars;
2488     foreach my $param_name ( keys %$cgi_params ) {
2489         if ( $param_name =~ /^tag_/ ) {
2490             my $param_value = $cgi_params->{$param_name};
2491             unless ( Encode::is_utf8( $param_value ) ) {
2492                 $cgi_params->{$param_name} = Encode::decode('UTF-8', $param_value );
2493             }
2494         }
2495     }
2496
2497     # creating a new record
2498     my $record = MARC::Record->new();
2499     my @fields;
2500     my ($biblionumbertagfield, $biblionumbertagsubfield) = (-1, -1);
2501     ($biblionumbertagfield, $biblionumbertagsubfield) =
2502         &GetMarcFromKohaField( "biblio.biblionumber", '' ) if $isbiblio;
2503 #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!
2504     for (my $i = 0; $params[$i]; $i++ ) {    # browse all CGI params
2505         my $param    = $params[$i];
2506         my $newfield = 0;
2507
2508         # if we are on biblionumber, store it in the MARC::Record (it may not be in the edited fields)
2509         if ( $param eq 'biblionumber' ) {
2510             if ( $biblionumbertagfield < 10 ) {
2511                 $newfield = MARC::Field->new( $biblionumbertagfield, scalar $cgi->param($param), );
2512             } else {
2513                 $newfield = MARC::Field->new( $biblionumbertagfield, '', '', "$biblionumbertagsubfield" => scalar $cgi->param($param), );
2514             }
2515             push @fields, $newfield if ($newfield);
2516         } elsif ( $param =~ /^tag_(\d*)_indicator1_/ ) {    # new field start when having 'input name="..._indicator1_..."
2517             my $tag = $1;
2518
2519             my $ind1 = _default_ind_to_space( substr( $cgi->param($param), 0, 1 ) );
2520             my $ind2 = _default_ind_to_space( substr( $cgi->param( $params[ $i + 1 ] ), 0, 1 ) );
2521             $newfield = 0;
2522             my $j = $i + 2;
2523
2524             if ( $tag < 10 ) {                              # no code for theses fields
2525                                                             # in MARC editor, 000 contains the leader.
2526                 next if $tag == $biblionumbertagfield;
2527                 my $fval= $cgi->param($params[$j+1]);
2528                 if ( $tag eq '000' ) {
2529                     # Force a fake leader even if not provided to avoid crashing
2530                     # during decoding MARC record containing UTF-8 characters
2531                     $record->leader(
2532                         length( $fval ) == 24
2533                         ? $fval
2534                         : '     nam a22        4500'
2535                         )
2536                     ;
2537                     # between 001 and 009 (included)
2538                 } elsif ( $fval ne '' ) {
2539                     $newfield = MARC::Field->new( $tag, $fval, );
2540                 }
2541
2542                 # > 009, deal with subfields
2543             } else {
2544                 # browse subfields for this tag (reason for _code_ match)
2545                 while(defined $params[$j] && $params[$j] =~ /_code_/) {
2546                     last unless defined $params[$j+1];
2547                     $j += 2 and next
2548                         if $tag == $biblionumbertagfield and
2549                            $cgi->param($params[$j]) eq $biblionumbertagsubfield;
2550                     #if next param ne subfield, then it was probably empty
2551                     #try next param by incrementing j
2552                     if($params[$j+1]!~/_subfield_/) {$j++; next; }
2553                     my $fkey= $cgi->param($params[$j]);
2554                     my $fval= $cgi->param($params[$j+1]);
2555                     #check if subfield value not empty and field exists
2556                     if($fval ne '' && $newfield) {
2557                         $newfield->add_subfields( $fkey => $fval);
2558                     }
2559                     elsif($fval ne '') {
2560                         $newfield = MARC::Field->new( $tag, $ind1, $ind2, $fkey => $fval );
2561                     }
2562                     $j += 2;
2563                 } #end-of-while
2564                 $i= $j-1; #update i for outer loop accordingly
2565             }
2566             push @fields, $newfield if ($newfield);
2567         }
2568     }
2569
2570     $record->append_fields(@fields);
2571     return $record;
2572 }
2573
2574 =head2 TransformMarcToKoha
2575
2576     $result = TransformMarcToKoha( $record, undef, $limit )
2577
2578 Extract data from a MARC bib record into a hashref representing
2579 Koha biblio, biblioitems, and items fields.
2580
2581 If passed an undefined record will log the error and return an empty
2582 hash_ref.
2583
2584 =cut
2585
2586 sub TransformMarcToKoha {
2587     my ( $record, $frameworkcode, $limit_table ) = @_;
2588     # FIXME  Parameter $frameworkcode is obsolete and will be removed
2589     $limit_table //= q{};
2590
2591     my $result = {};
2592     if (!defined $record) {
2593         carp('TransformMarcToKoha called with undefined record');
2594         return $result;
2595     }
2596
2597     my %tables = ( biblio => 1, biblioitems => 1, items => 1 );
2598     if( $limit_table eq 'items' ) {
2599         %tables = ( items => 1 );
2600     }
2601
2602     # The next call acknowledges Default as the authoritative framework
2603     # for Koha to MARC mappings.
2604     my $mss = GetMarcSubfieldStructure(''); # Do not change framework
2605     foreach my $kohafield ( keys %{ $mss } ) {
2606         my ( $table, $column ) = split /[.]/, $kohafield, 2;
2607         next unless $tables{$table};
2608         my $val = TransformMarcToKohaOneField( $kohafield, $record );
2609         next if !defined $val;
2610         my $key = _disambiguate( $table, $column );
2611         $result->{$key} = $val;
2612     }
2613     return $result;
2614 }
2615
2616 =head2 _disambiguate
2617
2618   $newkey = _disambiguate($table, $field);
2619
2620 This is a temporary hack to distinguish between the
2621 following sets of columns when using TransformMarcToKoha.
2622
2623   items.cn_source & biblioitems.cn_source
2624   items.cn_sort & biblioitems.cn_sort
2625
2626 Columns that are currently NOT distinguished (FIXME
2627 due to lack of time to fully test) are:
2628
2629   biblio.notes and biblioitems.notes
2630   biblionumber
2631   timestamp
2632   biblioitemnumber
2633
2634 FIXME - this is necessary because prefixing each column
2635 name with the table name would require changing lots
2636 of code and templates, and exposing more of the DB
2637 structure than is good to the UI templates, particularly
2638 since biblio and bibloitems may well merge in a future
2639 version.  In the future, it would also be good to
2640 separate DB access and UI presentation field names
2641 more.
2642
2643 =cut
2644
2645 sub _disambiguate {
2646     my ( $table, $column ) = @_;
2647     if ( $column eq "cn_sort" or $column eq "cn_source" ) {
2648         return $table . '.' . $column;
2649     } else {
2650         return $column;
2651     }
2652
2653 }
2654
2655 =head2 TransformMarcToKohaOneField
2656
2657     $val = TransformMarcToKohaOneField( 'biblio.title', $marc );
2658
2659     Note: The authoritative Default framework is used implicitly.
2660
2661 =cut
2662
2663 sub TransformMarcToKohaOneField {
2664     my ( $kohafield, $marc ) = @_;
2665
2666     my ( @rv, $retval );
2667     my @mss = GetMarcSubfieldStructureFromKohaField($kohafield);
2668     foreach my $fldhash ( @mss ) {
2669         my $tag = $fldhash->{tagfield};
2670         my $sub = $fldhash->{tagsubfield};
2671         foreach my $fld ( $marc->field($tag) ) {
2672             if( $sub eq '@' || $fld->is_control_field ) {
2673                 push @rv, $fld->data if $fld->data;
2674             } else {
2675                 push @rv, grep { $_ } $fld->subfield($sub);
2676             }
2677         }
2678     }
2679     return unless @rv;
2680     $retval = join ' | ', uniq(@rv);
2681
2682     # Additional polishing for individual kohafields
2683     if( $kohafield =~ /copyrightdate|publicationyear/ ) {
2684         $retval = _adjust_pubyear( $retval );
2685     }
2686
2687     return $retval;
2688 }
2689
2690 =head2 _adjust_pubyear
2691
2692     Helper routine for TransformMarcToKohaOneField
2693
2694 =cut
2695
2696 sub _adjust_pubyear {
2697     my $retval = shift;
2698     # modify return value to keep only the 1st year found
2699     if( $retval =~ m/c(\d\d\d\d)/ and $1 > 0 ) { # search cYYYY first
2700         $retval = $1;
2701     } elsif( $retval =~ m/(\d\d\d\d)/ && $1 > 0 ) {
2702         $retval = $1;
2703     } elsif( $retval =~ m/(\d)[.Xx?]{3}|(\d\d)[.Xx?]{2}|(\d{3})[.Xx?]/ ) {
2704         my $digits = $1 || $2 || $3;
2705         $retval = $digits * ( 10 ** ( 4 - length($digits) ));
2706     } elsif( $retval =~ m/(\d)[-]{3}\?|(\d\d)[-]{2}\?|(\d{3})[-]\?/ ) {
2707         # the form 198-? occurred in Dutch ISBD rules
2708         my $digits = $1 || $2 || $3;
2709         $retval = $digits * ( 10 ** ( 4 - length($digits) ));
2710     }
2711     return $retval;
2712 }
2713
2714 =head2 CountItemsIssued
2715
2716     my $count = CountItemsIssued( $biblionumber );
2717
2718 =cut
2719
2720 sub CountItemsIssued {
2721     my ($biblionumber) = @_;
2722     my $dbh            = C4::Context->dbh;
2723     my $sth            = $dbh->prepare('SELECT COUNT(*) as issuedCount FROM items, issues WHERE items.itemnumber = issues.itemnumber AND items.biblionumber = ?');
2724     $sth->execute($biblionumber);
2725     my $row = $sth->fetchrow_hashref();
2726     return $row->{'issuedCount'};
2727 }
2728
2729 =head2 ModZebra
2730
2731   ModZebra( $biblionumber, $op, $server, $record );
2732
2733 $biblionumber is the biblionumber we want to index
2734
2735 $op is specialUpdate or recordDelete, and is used to know what we want to do
2736
2737 $server is the server that we want to update
2738
2739 $record is the update MARC record if it's available. If it's not supplied
2740 and is needed, it'll be loaded from the database.
2741
2742 =cut
2743
2744 sub ModZebra {
2745 ###Accepts a $server variable thus we can use it for biblios authorities or other zebra dbs
2746     my ( $biblionumber, $op, $server, $record ) = @_;
2747     $debug && warn "ModZebra: update requested for: $biblionumber $op $server\n";
2748     if ( C4::Context->preference('SearchEngine') eq 'Elasticsearch' ) {
2749
2750         # TODO abstract to a standard API that'll work for whatever
2751         require Koha::SearchEngine::Elasticsearch::Indexer;
2752         my $indexer = Koha::SearchEngine::Elasticsearch::Indexer->new(
2753             {
2754                 index => $server eq 'biblioserver'
2755                 ? $Koha::SearchEngine::BIBLIOS_INDEX
2756                 : $Koha::SearchEngine::AUTHORITIES_INDEX
2757             }
2758         );
2759         if ( $op eq 'specialUpdate' ) {
2760             unless ($record) {
2761                 $record = GetMarcBiblio({
2762                     biblionumber => $biblionumber,
2763                     embed_items  => 1 });
2764             }
2765             my $records = [$record];
2766             $indexer->update_index_background( [$biblionumber], [$record] );
2767         }
2768         elsif ( $op eq 'recordDelete' ) {
2769             $indexer->delete_index_background( [$biblionumber] );
2770         }
2771         else {
2772             croak "ModZebra called with unknown operation: $op";
2773         }
2774     }
2775
2776     my $dbh = C4::Context->dbh;
2777
2778     # true ModZebra commented until indexdata fixes zebraDB crashes (it seems they occur on multiple updates
2779     # at the same time
2780     # replaced by a zebraqueue table, that is filled with ModZebra to run.
2781     # the table is emptied by rebuild_zebra.pl script (using the -z switch)
2782     my $check_sql = "SELECT COUNT(*) FROM zebraqueue
2783     WHERE server = ?
2784         AND   biblio_auth_number = ?
2785         AND   operation = ?
2786         AND   done = 0";
2787     my $check_sth = $dbh->prepare_cached($check_sql);
2788     $check_sth->execute( $server, $biblionumber, $op );
2789     my ($count) = $check_sth->fetchrow_array;
2790     $check_sth->finish();
2791     if ( $count == 0 ) {
2792         my $sth = $dbh->prepare("INSERT INTO zebraqueue  (biblio_auth_number,server,operation) VALUES(?,?,?)");
2793         $sth->execute( $biblionumber, $server, $op );
2794         $sth->finish;
2795     }
2796 }
2797
2798
2799 =head2 EmbedItemsInMarcBiblio
2800
2801     EmbedItemsInMarcBiblio($marc, $biblionumber, $itemnumbers, $opac);
2802
2803 Given a MARC::Record object containing a bib record,
2804 modify it to include the items attached to it as 9XX
2805 per the bib's MARC framework.
2806 if $itemnumbers is defined, only specified itemnumbers are embedded.
2807
2808 If $opac is true, then opac-relevant suppressions are included.
2809
2810 =cut
2811
2812 sub EmbedItemsInMarcBiblio {
2813     my ($marc, $biblionumber, $itemnumbers, $opac) = @_;
2814     if ( !$marc ) {
2815         carp 'EmbedItemsInMarcBiblio: No MARC record passed';
2816         return;
2817     }
2818
2819     $itemnumbers = [] unless defined $itemnumbers;
2820
2821     my $frameworkcode = GetFrameworkCode($biblionumber);
2822     _strip_item_fields($marc, $frameworkcode);
2823
2824     # ... and embed the current items
2825     my $dbh = C4::Context->dbh;
2826     my $sth = $dbh->prepare("SELECT itemnumber FROM items WHERE biblionumber = ?");
2827     $sth->execute($biblionumber);
2828     my @item_fields;
2829     my ( $itemtag, $itemsubfield ) = GetMarcFromKohaField( "items.itemnumber", $frameworkcode );
2830     my @items;
2831     my $opachiddenitems = $opac
2832       && ( C4::Context->preference('OpacHiddenItems') !~ /^\s*$/ );
2833     require C4::Items;
2834     while ( my ($itemnumber) = $sth->fetchrow_array ) {
2835         next if @$itemnumbers and not grep { $_ == $itemnumber } @$itemnumbers;
2836         my $i = $opachiddenitems ? C4::Items::GetItem($itemnumber) : undef;
2837         push @items, { itemnumber => $itemnumber, item => $i };
2838     }
2839     my @hiddenitems =
2840       $opachiddenitems
2841       ? C4::Items::GetHiddenItemnumbers( map { $_->{item} } @items )
2842       : ();
2843     # Convert to a hash for quick searching
2844     my %hiddenitems = map { $_ => 1 } @hiddenitems;
2845     foreach my $itemnumber ( map { $_->{itemnumber} } @items ) {
2846         next if $hiddenitems{$itemnumber};
2847         my $item_marc = C4::Items::GetMarcItem( $biblionumber, $itemnumber );
2848         push @item_fields, $item_marc->field($itemtag);
2849     }
2850     $marc->append_fields(@item_fields);
2851 }
2852
2853 =head1 INTERNAL FUNCTIONS
2854
2855 =head2 _koha_marc_update_bib_ids
2856
2857
2858   _koha_marc_update_bib_ids($record, $frameworkcode, $biblionumber, $biblioitemnumber);
2859
2860 Internal function to add or update biblionumber and biblioitemnumber to
2861 the MARC XML.
2862
2863 =cut
2864
2865 sub _koha_marc_update_bib_ids {
2866     my ( $record, $frameworkcode, $biblionumber, $biblioitemnumber ) = @_;
2867
2868     my ( $biblio_tag,     $biblio_subfield )     = GetMarcFromKohaField( "biblio.biblionumber",          $frameworkcode );
2869     die qq{No biblionumber tag for framework "$frameworkcode"} unless $biblio_tag;
2870     my ( $biblioitem_tag, $biblioitem_subfield ) = GetMarcFromKohaField( "biblioitems.biblioitemnumber", $frameworkcode );
2871     die qq{No biblioitemnumber tag for framework "$frameworkcode"} unless $biblioitem_tag;
2872
2873     if ( $biblio_tag < 10 ) {
2874         C4::Biblio::UpsertMarcControlField( $record, $biblio_tag, $biblionumber );
2875     } else {
2876         C4::Biblio::UpsertMarcSubfield($record, $biblio_tag, $biblio_subfield, $biblionumber);
2877     }
2878     if ( $biblioitem_tag < 10 ) {
2879         C4::Biblio::UpsertMarcControlField( $record, $biblioitem_tag, $biblioitemnumber );
2880     } else {
2881         C4::Biblio::UpsertMarcSubfield($record, $biblioitem_tag, $biblioitem_subfield, $biblioitemnumber);
2882     }
2883 }
2884
2885 =head2 _koha_marc_update_biblioitem_cn_sort
2886
2887   _koha_marc_update_biblioitem_cn_sort($marc, $biblioitem, $frameworkcode);
2888
2889 Given a MARC bib record and the biblioitem hash, update the
2890 subfield that contains a copy of the value of biblioitems.cn_sort.
2891
2892 =cut
2893
2894 sub _koha_marc_update_biblioitem_cn_sort {
2895     my $marc          = shift;
2896     my $biblioitem    = shift;
2897     my $frameworkcode = shift;
2898
2899     my ( $biblioitem_tag, $biblioitem_subfield ) = GetMarcFromKohaField( "biblioitems.cn_sort", $frameworkcode );
2900     return unless $biblioitem_tag;
2901
2902     my ($cn_sort) = GetClassSort( $biblioitem->{'biblioitems.cn_source'}, $biblioitem->{'cn_class'}, $biblioitem->{'cn_item'} );
2903
2904     if ( my $field = $marc->field($biblioitem_tag) ) {
2905         $field->delete_subfield( code => $biblioitem_subfield );
2906         if ( $cn_sort ne '' ) {
2907             $field->add_subfields( $biblioitem_subfield => $cn_sort );
2908         }
2909     } else {
2910
2911         # if we get here, no biblioitem tag is present in the MARC record, so
2912         # we'll create it if $cn_sort is not empty -- this would be
2913         # an odd combination of events, however
2914         if ($cn_sort) {
2915             $marc->insert_grouped_field( MARC::Field->new( $biblioitem_tag, ' ', ' ', $biblioitem_subfield => $cn_sort ) );
2916         }
2917     }
2918 }
2919
2920 =head2 _koha_add_biblio
2921
2922   my ($biblionumber,$error) = _koha_add_biblio($dbh,$biblioitem);
2923
2924 Internal function to add a biblio ($biblio is a hash with the values)
2925
2926 =cut
2927
2928 sub _koha_add_biblio {
2929     my ( $dbh, $biblio, $frameworkcode ) = @_;
2930
2931     my $error;
2932
2933     # set the series flag
2934     unless (defined $biblio->{'serial'}){
2935         $biblio->{'serial'} = 0;
2936         if ( $biblio->{'seriestitle'} ) { $biblio->{'serial'} = 1 }
2937     }
2938
2939     my $query = "INSERT INTO biblio
2940         SET frameworkcode = ?,
2941             author = ?,
2942             title = ?,
2943             unititle =?,
2944             notes = ?,
2945             serial = ?,
2946             seriestitle = ?,
2947             copyrightdate = ?,
2948             datecreated=NOW(),
2949             abstract = ?
2950         ";
2951     my $sth = $dbh->prepare($query);
2952     $sth->execute(
2953         $frameworkcode, $biblio->{'author'},      $biblio->{'title'},         $biblio->{'unititle'}, $biblio->{'notes'},
2954         $biblio->{'serial'},        $biblio->{'seriestitle'}, $biblio->{'copyrightdate'}, $biblio->{'abstract'}
2955     );
2956
2957     my $biblionumber = $dbh->{'mysql_insertid'};
2958     if ( $dbh->errstr ) {
2959         $error .= "ERROR in _koha_add_biblio $query" . $dbh->errstr;
2960         warn $error;
2961     }
2962
2963     $sth->finish();
2964
2965     #warn "LEAVING _koha_add_biblio: ".$biblionumber."\n";
2966     return ( $biblionumber, $error );
2967 }
2968
2969 =head2 _koha_modify_biblio
2970
2971   my ($biblionumber,$error) == _koha_modify_biblio($dbh,$biblio,$frameworkcode);
2972
2973 Internal function for updating the biblio table
2974
2975 =cut
2976
2977 sub _koha_modify_biblio {
2978     my ( $dbh, $biblio, $frameworkcode ) = @_;
2979     my $error;
2980
2981     my $query = "
2982         UPDATE biblio
2983         SET    frameworkcode = ?,
2984                author = ?,
2985                title = ?,
2986                unititle = ?,
2987                notes = ?,
2988                serial = ?,
2989                seriestitle = ?,
2990                copyrightdate = ?,
2991                abstract = ?
2992         WHERE  biblionumber = ?
2993         "
2994       ;
2995     my $sth = $dbh->prepare($query);
2996
2997     $sth->execute(
2998         $frameworkcode,      $biblio->{'author'},      $biblio->{'title'},         $biblio->{'unititle'}, $biblio->{'notes'},
2999         $biblio->{'serial'}, $biblio->{'seriestitle'}, $biblio->{'copyrightdate'}, $biblio->{'abstract'}, $biblio->{'biblionumber'}
3000     ) if $biblio->{'biblionumber'};
3001
3002     if ( $dbh->errstr || !$biblio->{'biblionumber'} ) {
3003         $error .= "ERROR in _koha_modify_biblio $query" . $dbh->errstr;
3004         warn $error;
3005     }
3006     return ( $biblio->{'biblionumber'}, $error );
3007 }
3008
3009 =head2 _koha_modify_biblioitem_nonmarc
3010
3011   my ($biblioitemnumber,$error) = _koha_modify_biblioitem_nonmarc( $dbh, $biblioitem );
3012
3013 =cut
3014
3015 sub _koha_modify_biblioitem_nonmarc {
3016     my ( $dbh, $biblioitem ) = @_;
3017     my $error;
3018
3019     # re-calculate the cn_sort, it may have changed
3020     my ($cn_sort) = GetClassSort( $biblioitem->{'biblioitems.cn_source'}, $biblioitem->{'cn_class'}, $biblioitem->{'cn_item'} );
3021
3022     my $query = "UPDATE biblioitems
3023     SET biblionumber    = ?,
3024         volume          = ?,
3025         number          = ?,
3026         itemtype        = ?,
3027         isbn            = ?,
3028         issn            = ?,
3029         publicationyear = ?,
3030         publishercode   = ?,
3031         volumedate      = ?,
3032         volumedesc      = ?,
3033         collectiontitle = ?,
3034         collectionissn  = ?,
3035         collectionvolume= ?,
3036         editionstatement= ?,
3037         editionresponsibility = ?,
3038         illus           = ?,
3039         pages           = ?,
3040         notes           = ?,
3041         size            = ?,
3042         place           = ?,
3043         lccn            = ?,
3044         url             = ?,
3045         cn_source       = ?,
3046         cn_class        = ?,
3047         cn_item         = ?,
3048         cn_suffix       = ?,
3049         cn_sort         = ?,
3050         totalissues     = ?,
3051         ean             = ?,
3052         agerestriction  = ?
3053         where biblioitemnumber = ?
3054         ";
3055     my $sth = $dbh->prepare($query);
3056     $sth->execute(
3057         $biblioitem->{'biblionumber'},     $biblioitem->{'volume'},           $biblioitem->{'number'},                $biblioitem->{'itemtype'},
3058         $biblioitem->{'isbn'},             $biblioitem->{'issn'},             $biblioitem->{'publicationyear'},       $biblioitem->{'publishercode'},
3059         $biblioitem->{'volumedate'},       $biblioitem->{'volumedesc'},       $biblioitem->{'collectiontitle'},       $biblioitem->{'collectionissn'},
3060         $biblioitem->{'collectionvolume'}, $biblioitem->{'editionstatement'}, $biblioitem->{'editionresponsibility'}, $biblioitem->{'illus'},
3061         $biblioitem->{'pages'},            $biblioitem->{'bnotes'},           $biblioitem->{'size'},                  $biblioitem->{'place'},
3062         $biblioitem->{'lccn'},             $biblioitem->{'url'},              $biblioitem->{'biblioitems.cn_source'}, $biblioitem->{'cn_class'},
3063         $biblioitem->{'cn_item'},          $biblioitem->{'cn_suffix'},        $cn_sort,                               $biblioitem->{'totalissues'},
3064         $biblioitem->{'ean'},              $biblioitem->{'agerestriction'},   $biblioitem->{'biblioitemnumber'}
3065     );
3066     if ( $dbh->errstr ) {
3067         $error .= "ERROR in _koha_modify_biblioitem_nonmarc $query" . $dbh->errstr;
3068         warn $error;
3069     }
3070     return ( $biblioitem->{'biblioitemnumber'}, $error );
3071 }
3072
3073 =head2 _koha_add_biblioitem
3074
3075   my ($biblioitemnumber,$error) = _koha_add_biblioitem( $dbh, $biblioitem );
3076
3077 Internal function to add a biblioitem
3078
3079 =cut
3080
3081 sub _koha_add_biblioitem {
3082     my ( $dbh, $biblioitem ) = @_;
3083     my $error;
3084
3085     my ($cn_sort) = GetClassSort( $biblioitem->{'biblioitems.cn_source'}, $biblioitem->{'cn_class'}, $biblioitem->{'cn_item'} );
3086     my $query = "INSERT INTO biblioitems SET
3087         biblionumber    = ?,
3088         volume          = ?,
3089         number          = ?,
3090         itemtype        = ?,
3091         isbn            = ?,
3092         issn            = ?,
3093         publicationyear = ?,
3094         publishercode   = ?,
3095         volumedate      = ?,
3096         volumedesc      = ?,
3097         collectiontitle = ?,
3098         collectionissn  = ?,
3099         collectionvolume= ?,
3100         editionstatement= ?,
3101         editionresponsibility = ?,
3102         illus           = ?,
3103         pages           = ?,
3104         notes           = ?,
3105         size            = ?,
3106         place           = ?,
3107         lccn            = ?,
3108         url             = ?,
3109         cn_source       = ?,
3110         cn_class        = ?,
3111         cn_item         = ?,
3112         cn_suffix       = ?,
3113         cn_sort         = ?,
3114         totalissues     = ?,
3115         ean             = ?,
3116         agerestriction  = ?
3117         ";
3118     my $sth = $dbh->prepare($query);
3119     $sth->execute(
3120         $biblioitem->{'biblionumber'},     $biblioitem->{'volume'},           $biblioitem->{'number'},                $biblioitem->{'itemtype'},
3121         $biblioitem->{'isbn'},             $biblioitem->{'issn'},             $biblioitem->{'publicationyear'},       $biblioitem->{'publishercode'},
3122         $biblioitem->{'volumedate'},       $biblioitem->{'volumedesc'},       $biblioitem->{'collectiontitle'},       $biblioitem->{'collectionissn'},
3123         $biblioitem->{'collectionvolume'}, $biblioitem->{'editionstatement'}, $biblioitem->{'editionresponsibility'}, $biblioitem->{'illus'},
3124         $biblioitem->{'pages'},            $biblioitem->{'bnotes'},           $biblioitem->{'size'},                  $biblioitem->{'place'},
3125         $biblioitem->{'lccn'},             $biblioitem->{'url'},                   $biblioitem->{'biblioitems.cn_source'},
3126         $biblioitem->{'cn_class'},         $biblioitem->{'cn_item'},          $biblioitem->{'cn_suffix'},             $cn_sort,
3127         $biblioitem->{'totalissues'},      $biblioitem->{'ean'},              $biblioitem->{'agerestriction'}
3128     );
3129     my $bibitemnum = $dbh->{'mysql_insertid'};
3130
3131     if ( $dbh->errstr ) {
3132         $error .= "ERROR in _koha_add_biblioitem $query" . $dbh->errstr;
3133         warn $error;
3134     }
3135     $sth->finish();
3136     return ( $bibitemnum, $error );
3137 }
3138
3139 =head2 _koha_delete_biblio
3140
3141   $error = _koha_delete_biblio($dbh,$biblionumber);
3142
3143 Internal sub for deleting from biblio table -- also saves to deletedbiblio
3144
3145 C<$dbh> - the database handle
3146
3147 C<$biblionumber> - the biblionumber of the biblio to be deleted
3148
3149 =cut
3150
3151 # FIXME: add error handling
3152
3153 sub _koha_delete_biblio {
3154     my ( $dbh, $biblionumber ) = @_;
3155
3156     # get all the data for this biblio
3157     my $sth = $dbh->prepare("SELECT * FROM biblio WHERE biblionumber=?");
3158     $sth->execute($biblionumber);
3159
3160     # FIXME There is a transaction in _koha_delete_biblio_metadata
3161     # But actually all the following should be done inside a single transaction
3162     if ( my $data = $sth->fetchrow_hashref ) {
3163
3164         # save the record in deletedbiblio
3165         # find the fields to save
3166         my $query = "INSERT INTO deletedbiblio SET ";
3167         my @bind  = ();
3168         foreach my $temp ( keys %$data ) {
3169             $query .= "$temp = ?,";
3170             push( @bind, $data->{$temp} );
3171         }
3172
3173         # replace the last , by ",?)"
3174         $query =~ s/\,$//;
3175         my $bkup_sth = $dbh->prepare($query);
3176         $bkup_sth->execute(@bind);
3177         $bkup_sth->finish;
3178
3179         _koha_delete_biblio_metadata( $biblionumber );
3180
3181         # delete the biblio
3182         my $sth2 = $dbh->prepare("DELETE FROM biblio WHERE biblionumber=?");
3183         $sth2->execute($biblionumber);
3184         # update the timestamp (Bugzilla 7146)
3185         $sth2= $dbh->prepare("UPDATE deletedbiblio SET timestamp=NOW() WHERE biblionumber=?");
3186         $sth2->execute($biblionumber);
3187         $sth2->finish;
3188     }
3189     $sth->finish;
3190     return;
3191 }
3192
3193 =head2 _koha_delete_biblioitems
3194
3195   $error = _koha_delete_biblioitems($dbh,$biblioitemnumber);
3196
3197 Internal sub for deleting from biblioitems table -- also saves to deletedbiblioitems
3198
3199 C<$dbh> - the database handle
3200 C<$biblionumber> - the biblioitemnumber of the biblioitem to be deleted
3201
3202 =cut
3203
3204 # FIXME: add error handling
3205
3206 sub _koha_delete_biblioitems {
3207     my ( $dbh, $biblioitemnumber ) = @_;
3208
3209     # get all the data for this biblioitem
3210     my $sth = $dbh->prepare("SELECT * FROM biblioitems WHERE biblioitemnumber=?");
3211     $sth->execute($biblioitemnumber);
3212
3213     if ( my $data = $sth->fetchrow_hashref ) {
3214
3215         # save the record in deletedbiblioitems
3216         # find the fields to save
3217         my $query = "INSERT INTO deletedbiblioitems SET ";
3218         my @bind  = ();
3219         foreach my $temp ( keys %$data ) {
3220             $query .= "$temp = ?,";
3221             push( @bind, $data->{$temp} );
3222         }
3223
3224         # replace the last , by ",?)"
3225         $query =~ s/\,$//;
3226         my $bkup_sth = $dbh->prepare($query);
3227         $bkup_sth->execute(@bind);
3228         $bkup_sth->finish;
3229
3230         # delete the biblioitem
3231         my $sth2 = $dbh->prepare("DELETE FROM biblioitems WHERE biblioitemnumber=?");
3232         $sth2->execute($biblioitemnumber);
3233         # update the timestamp (Bugzilla 7146)
3234         $sth2= $dbh->prepare("UPDATE deletedbiblioitems SET timestamp=NOW() WHERE biblioitemnumber=?");
3235         $sth2->execute($biblioitemnumber);
3236         $sth2->finish;
3237     }
3238     $sth->finish;
3239     return;
3240 }
3241
3242 =head2 _koha_delete_biblio_metadata
3243
3244   $error = _koha_delete_biblio_metadata($biblionumber);
3245
3246 C<$biblionumber> - the biblionumber of the biblio metadata to be deleted
3247
3248 =cut
3249
3250 sub _koha_delete_biblio_metadata {
3251     my ($biblionumber) = @_;
3252
3253     my $dbh    = C4::Context->dbh;
3254     my $schema = Koha::Database->new->schema;
3255     $schema->txn_do(
3256         sub {
3257             $dbh->do( q|
3258                 INSERT INTO deletedbiblio_metadata (biblionumber, format, marcflavour, metadata)
3259                 SELECT biblionumber, format, marcflavour, metadata FROM biblio_metadata WHERE biblionumber=?
3260             |,  undef, $biblionumber );
3261             $dbh->do( q|DELETE FROM biblio_metadata WHERE biblionumber=?|,
3262                 undef, $biblionumber );
3263         }
3264     );
3265 }
3266
3267 =head1 UNEXPORTED FUNCTIONS
3268
3269 =head2 ModBiblioMarc
3270
3271   &ModBiblioMarc($newrec,$biblionumber,$frameworkcode);
3272
3273 Add MARC XML data for a biblio to koha
3274
3275 Function exported, but should NOT be used, unless you really know what you're doing
3276
3277 =cut
3278
3279 sub ModBiblioMarc {
3280     # pass the MARC::Record to this function, and it will create the records in
3281     # the marcxml field
3282     my ( $record, $biblionumber, $frameworkcode ) = @_;
3283     if ( !$record ) {
3284         carp 'ModBiblioMarc passed an undefined record';
3285         return;
3286     }
3287
3288     # Clone record as it gets modified
3289     $record = $record->clone();
3290     my $dbh    = C4::Context->dbh;
3291     my @fields = $record->fields();
3292     if ( !$frameworkcode ) {
3293         $frameworkcode = "";
3294     }
3295     my $sth = $dbh->prepare("UPDATE biblio SET frameworkcode=? WHERE biblionumber=?");
3296     $sth->execute( $frameworkcode, $biblionumber );
3297     $sth->finish;
3298     my $encoding = C4::Context->preference("marcflavour");
3299
3300     # deal with UNIMARC field 100 (encoding) : create it if needed & set encoding to unicode
3301     if ( $encoding eq "UNIMARC" ) {
3302         my $defaultlanguage = C4::Context->preference("UNIMARCField100Language");
3303         $defaultlanguage = "fre" if (!$defaultlanguage || length($defaultlanguage) != 3);
3304         my $string = $record->subfield( 100, "a" );
3305         if ( ($string) && ( length( $record->subfield( 100, "a" ) ) == 36 ) ) {
3306             my $f100 = $record->field(100);
3307             $record->delete_field($f100);
3308         } else {
3309             $string = POSIX::strftime( "%Y%m%d", localtime );
3310             $string =~ s/\-//g;
3311             $string = sprintf( "%-*s", 35, $string );
3312             substr ( $string, 22, 3, $defaultlanguage);
3313         }
3314         substr( $string, 25, 3, "y50" );
3315         unless ( $record->subfield( 100, "a" ) ) {
3316             $record->insert_fields_ordered( MARC::Field->new( 100, "", "", "a" => $string ) );
3317         }
3318     }
3319
3320     #enhancement 5374: update transaction date (005) for marc21/unimarc
3321     if($encoding =~ /MARC21|UNIMARC/) {
3322       my @a= (localtime) [5,4,3,2,1,0]; $a[0]+=1900; $a[1]++;
3323         # YY MM DD HH MM SS (update year and month)
3324       my $f005= $record->field('005');
3325       $f005->update(sprintf("%4d%02d%02d%02d%02d%04.1f",@a)) if $f005;
3326     }
3327
3328     my $metadata = {
3329         biblionumber => $biblionumber,
3330         format       => 'marcxml',
3331         marcflavour  => C4::Context->preference('marcflavour'),
3332     };
3333     # FIXME To replace with ->find_or_create?
3334     if ( my $m_rs = Koha::Biblio::Metadatas->find($metadata) ) {
3335         $m_rs->metadata( $record->as_xml_record($encoding) );
3336         $m_rs->store;
3337     } else {
3338         my $m_rs = Koha::Biblio::Metadata->new($metadata);
3339         $m_rs->metadata( $record->as_xml_record($encoding) );
3340         $m_rs->store;
3341     }
3342     ModZebra( $biblionumber, "specialUpdate", "biblioserver", $record );
3343     return $biblionumber;
3344 }
3345
3346 =head2 CountBiblioInOrders
3347
3348     $count = &CountBiblioInOrders( $biblionumber);
3349
3350 This function return count of biblios in orders with $biblionumber
3351
3352 =cut
3353
3354 sub CountBiblioInOrders {
3355  my ($biblionumber) = @_;
3356     my $dbh            = C4::Context->dbh;
3357     my $query          = "SELECT count(*)
3358           FROM  aqorders
3359           WHERE biblionumber=? AND (datecancellationprinted IS NULL OR datecancellationprinted='0000-00-00')";
3360     my $sth = $dbh->prepare($query);
3361     $sth->execute($biblionumber);
3362     my $count = $sth->fetchrow;
3363     return ($count);
3364 }
3365
3366 =head2 prepare_host_field
3367
3368 $marcfield = prepare_host_field( $hostbiblioitem, $marcflavour );
3369 Generate the host item entry for an analytic child entry
3370
3371 =cut
3372
3373 sub prepare_host_field {
3374     my ( $hostbiblio, $marcflavour ) = @_;
3375     $marcflavour ||= C4::Context->preference('marcflavour');
3376     my $host = GetMarcBiblio({ biblionumber => $hostbiblio });
3377     # unfortunately as_string does not 'do the right thing'
3378     # if field returns undef
3379     my %sfd;
3380     my $field;
3381     my $host_field;
3382     if ( $marcflavour eq 'MARC21' || $marcflavour eq 'NORMARC' ) {
3383         if ( $field = $host->field('100') || $host->field('110') || $host->field('11') ) {
3384             my $s = $field->as_string('ab');
3385             if ($s) {
3386                 $sfd{a} = $s;
3387             }
3388         }
3389         if ( $field = $host->field('245') ) {
3390             my $s = $field->as_string('a');
3391             if ($s) {
3392                 $sfd{t} = $s;
3393             }
3394         }
3395         if ( $field = $host->field('260') ) {
3396             my $s = $field->as_string('abc');
3397             if ($s) {
3398                 $sfd{d} = $s;
3399             }
3400         }
3401         if ( $field = $host->field('240') ) {
3402             my $s = $field->as_string();
3403             if ($s) {
3404                 $sfd{b} = $s;
3405             }
3406         }
3407         if ( $field = $host->field('022') ) {
3408             my $s = $field->as_string('a');
3409             if ($s) {
3410                 $sfd{x} = $s;
3411             }
3412         }
3413         if ( $field = $host->field('020') ) {
3414             my $s = $field->as_string('a');
3415             if ($s) {
3416                 $sfd{z} = $s;
3417             }
3418         }
3419         if ( $field = $host->field('001') ) {
3420             $sfd{w} = $field->data(),;
3421         }
3422         $host_field = MARC::Field->new( 773, '0', ' ', %sfd );
3423         return $host_field;
3424     }
3425     elsif ( $marcflavour eq 'UNIMARC' ) {
3426         #author
3427         if ( $field = $host->field('700') || $host->field('710') || $host->field('720') ) {
3428             my $s = $field->as_string('ab');
3429             if ($s) {
3430                 $sfd{a} = $s;
3431             }
3432         }
3433         #title
3434         if ( $field = $host->field('200') ) {
3435             my $s = $field->as_string('a');
3436             if ($s) {
3437                 $sfd{t} = $s;
3438             }
3439         }
3440         #place of publicaton
3441         if ( $field = $host->field('210') ) {
3442             my $s = $field->as_string('a');
3443             if ($s) {
3444                 $sfd{c} = $s;
3445             }
3446         }
3447         #date of publication
3448         if ( $field = $host->field('210') ) {
3449             my $s = $field->as_string('d');
3450             if ($s) {
3451                 $sfd{d} = $s;
3452             }
3453         }
3454         #edition statement
3455         if ( $field = $host->field('205') ) {
3456             my $s = $field->as_string();
3457             if ($s) {
3458                 $sfd{e} = $s;
3459             }
3460         }
3461         #URL
3462         if ( $field = $host->field('856') ) {
3463             my $s = $field->as_string('u');
3464             if ($s) {
3465                 $sfd{u} = $s;
3466             }
3467         }
3468         #ISSN
3469         if ( $field = $host->field('011') ) {
3470             my $s = $field->as_string('a');
3471             if ($s) {
3472                 $sfd{x} = $s;
3473             }
3474         }
3475         #ISBN
3476         if ( $field = $host->field('010') ) {
3477             my $s = $field->as_string('a');
3478             if ($s) {
3479                 $sfd{y} = $s;
3480             }
3481         }
3482         if ( $field = $host->field('001') ) {
3483             $sfd{0} = $field->data(),;
3484         }
3485         $host_field = MARC::Field->new( 461, '0', ' ', %sfd );
3486         return $host_field;
3487     }
3488     return;
3489 }
3490
3491
3492 =head2 UpdateTotalIssues
3493
3494   UpdateTotalIssues($biblionumber, $increase, [$value])
3495
3496 Update the total issue count for a particular bib record.
3497
3498 =over 4
3499
3500 =item C<$biblionumber> is the biblionumber of the bib to update
3501
3502 =item C<$increase> is the amount to increase (or decrease) the total issues count by
3503
3504 =item C<$value> is the absolute value that total issues count should be set to. If provided, C<$increase> is ignored.
3505
3506 =back
3507
3508 =cut
3509
3510 sub UpdateTotalIssues {
3511     my ($biblionumber, $increase, $value) = @_;
3512     my $totalissues;
3513
3514     my $record = GetMarcBiblio({ biblionumber => $biblionumber });
3515     unless ($record) {
3516         carp "UpdateTotalIssues could not get biblio record";
3517         return;
3518     }
3519     my $biblio = Koha::Biblios->find( $biblionumber );
3520     unless ($biblio) {
3521         carp "UpdateTotalIssues could not get datas of biblio";
3522         return;
3523     }
3524     my $biblioitem = $biblio->biblioitem;
3525     my ($totalissuestag, $totalissuessubfield) = GetMarcFromKohaField('biblioitems.totalissues', $biblio->frameworkcode);
3526     unless ($totalissuestag) {
3527         return 1; # There is nothing to do
3528     }
3529
3530     if (defined $value) {
3531         $totalissues = $value;
3532     } else {
3533         $totalissues = $biblioitem->totalissues + $increase;
3534     }
3535
3536      my $field = $record->field($totalissuestag);
3537      if (defined $field) {
3538          $field->update( $totalissuessubfield => $totalissues );
3539      } else {
3540          $field = MARC::Field->new($totalissuestag, '0', '0',
3541                  $totalissuessubfield => $totalissues);
3542          $record->insert_grouped_field($field);
3543      }
3544
3545      return ModBiblio($record, $biblionumber, $biblio->frameworkcode);
3546 }
3547
3548 =head2 RemoveAllNsb
3549
3550     &RemoveAllNsb($record);
3551
3552 Removes all nsb/nse chars from a record
3553
3554 =cut
3555
3556 sub RemoveAllNsb {
3557     my $record = shift;
3558     if (!$record) {
3559         carp 'RemoveAllNsb called with undefined record';
3560         return;
3561     }
3562
3563     SetUTF8Flag($record);
3564
3565     foreach my $field ($record->fields()) {
3566         if ($field->is_control_field()) {
3567             $field->update(nsb_clean($field->data()));
3568         } else {
3569             my @subfields = $field->subfields();
3570             my @new_subfields;
3571             foreach my $subfield (@subfields) {
3572                 push @new_subfields, $subfield->[0] => nsb_clean($subfield->[1]);
3573             }
3574             if (scalar(@new_subfields) > 0) {
3575                 my $new_field;
3576                 eval {
3577                     $new_field = MARC::Field->new(
3578                         $field->tag(),
3579                         $field->indicator(1),
3580                         $field->indicator(2),
3581                         @new_subfields
3582                     );
3583                 };
3584                 if ($@) {
3585                     warn "error in RemoveAllNsb : $@";
3586                 } else {
3587                     $field->replace_with($new_field);
3588                 }
3589             }
3590         }
3591     }
3592
3593     return $record;
3594 }
3595
3596 1;
3597
3598
3599 __END__
3600
3601 =head1 AUTHOR
3602
3603 Koha Development Team <http://koha-community.org/>
3604
3605 Paul POULAIN paul.poulain@free.fr
3606
3607 Joshua Ferraro jmf@liblime.com
3608
3609 =cut