C4/Biblio.pm

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