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