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