C4/Biblio.pm

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