C4/Biblio.pm

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