C4/Biblio.pm

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