C4/Biblio.pm

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