C4/Biblio.pm

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