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