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