C4/Biblio.pm

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