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