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