C4/Biblio.pm

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