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