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