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