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