Bug 24082: Add `anonymous_refund` permission to `cash_management`
[koha.git] / Koha / Biblio.pm
1 package Koha::Biblio;
2
3 # Copyright ByWater Solutions 2014
4 #
5 # This file is part of Koha.
6 #
7 # Koha is free software; you can redistribute it and/or modify it
8 # under the terms of the GNU General Public License as published by
9 # the Free Software Foundation; either version 3 of the License, or
10 # (at your option) any later version.
11 #
12 # Koha is distributed in the hope that it will be useful, but
13 # WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
16 #
17 # You should have received a copy of the GNU General Public License
18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
19
20 use Modern::Perl;
21
22 use Carp;
23 use List::MoreUtils qw(any);
24 use URI;
25 use URI::Escape;
26
27 use C4::Koha;
28 use C4::Biblio qw();
29
30 use Koha::Database;
31 use Koha::DateUtils qw( dt_from_string );
32
33 use base qw(Koha::Object);
34
35 use Koha::Acquisition::Orders;
36 use Koha::ArticleRequest::Status;
37 use Koha::ArticleRequests;
38 use Koha::Biblio::Metadatas;
39 use Koha::Biblioitems;
40 use Koha::CirculationRules;
41 use Koha::Item::Transfer::Limits;
42 use Koha::Items;
43 use Koha::Libraries;
44 use Koha::Suggestions;
45 use Koha::Subscriptions;
46
47 =head1 NAME
48
49 Koha::Biblio - Koha Biblio Object class
50
51 =head1 API
52
53 =head2 Class Methods
54
55 =cut
56
57 =head3 store
58
59 Overloaded I<store> method to set default values
60
61 =cut
62
63 sub store {
64     my ( $self ) = @_;
65
66     $self->datecreated( dt_from_string ) unless $self->datecreated;
67
68     return $self->SUPER::store;
69 }
70
71 =head3 metadata
72
73 my $metadata = $biblio->metadata();
74
75 Returns a Koha::Biblio::Metadata object
76
77 =cut
78
79 sub metadata {
80     my ( $self ) = @_;
81
82     my $metadata = $self->_result->metadata;
83     return Koha::Biblio::Metadata->_new_from_dbic($metadata);
84 }
85
86 =head3 orders
87
88 my $orders = $biblio->orders();
89
90 Returns a Koha::Acquisition::Orders object
91
92 =cut
93
94 sub orders {
95     my ( $self ) = @_;
96
97     my $orders = $self->_result->orders;
98     return Koha::Acquisition::Orders->_new_from_dbic($orders);
99 }
100
101 =head3 active_orders
102
103 my $active_orders = $biblio->active_orders();
104
105 Returns the active acquisition orders related to this biblio.
106 An order is considered active when it is not cancelled (i.e. when datecancellation
107 is not undef).
108
109 =cut
110
111 sub active_orders {
112     my ( $self ) = @_;
113
114     return $self->orders->search({ datecancellationprinted => undef });
115 }
116
117 =head3 can_article_request
118
119 my $bool = $biblio->can_article_request( $borrower );
120
121 Returns true if article requests can be made for this record
122
123 $borrower must be a Koha::Patron object
124
125 =cut
126
127 sub can_article_request {
128     my ( $self, $borrower ) = @_;
129
130     my $rule = $self->article_request_type($borrower);
131     return q{} if $rule eq 'item_only' && !$self->items()->count();
132     return 1 if $rule && $rule ne 'no';
133
134     return q{};
135 }
136
137 =head3 can_be_transferred
138
139 $biblio->can_be_transferred({ to => $to_library, from => $from_library })
140
141 Checks if at least one item of a biblio can be transferred to given library.
142
143 This feature is controlled by two system preferences:
144 UseBranchTransferLimits to enable / disable the feature
145 BranchTransferLimitsType to use either an itemnumber or ccode as an identifier
146                          for setting the limitations
147
148 Performance-wise, it is recommended to use this method for a biblio instead of
149 iterating each item of a biblio with Koha::Item->can_be_transferred().
150
151 Takes HASHref that can have the following parameters:
152     MANDATORY PARAMETERS:
153     $to   : Koha::Library
154     OPTIONAL PARAMETERS:
155     $from : Koha::Library # if given, only items from that
156                           # holdingbranch are considered
157
158 Returns 1 if at least one of the item of a biblio can be transferred
159 to $to_library, otherwise 0.
160
161 =cut
162
163 sub can_be_transferred {
164     my ($self, $params) = @_;
165
166     my $to   = $params->{to};
167     my $from = $params->{from};
168
169     return 1 unless C4::Context->preference('UseBranchTransferLimits');
170     my $limittype = C4::Context->preference('BranchTransferLimitsType');
171
172     my $items;
173     foreach my $item_of_bib ($self->items->as_list) {
174         next unless $item_of_bib->holdingbranch;
175         next if $from && $from->branchcode ne $item_of_bib->holdingbranch;
176         return 1 if $item_of_bib->holdingbranch eq $to->branchcode;
177         my $code = $limittype eq 'itemtype'
178             ? $item_of_bib->effective_itemtype
179             : $item_of_bib->ccode;
180         return 1 unless $code;
181         $items->{$code}->{$item_of_bib->holdingbranch} = 1;
182     }
183
184     # At this point we will have a HASHref containing each itemtype/ccode that
185     # this biblio has, inside which are all of the holdingbranches where those
186     # items are located at. Then, we will query Koha::Item::Transfer::Limits to
187     # find out whether a transfer limits for such $limittype from any of the
188     # listed holdingbranches to the given $to library exist. If at least one
189     # holdingbranch for that $limittype does not have a transfer limit to given
190     # $to library, then we know that the transfer is possible.
191     foreach my $code (keys %{$items}) {
192         my @holdingbranches = keys %{$items->{$code}};
193         return 1 if Koha::Item::Transfer::Limits->search({
194             toBranch => $to->branchcode,
195             fromBranch => { 'in' => \@holdingbranches },
196             $limittype => $code
197         }, {
198             group_by => [qw/fromBranch/]
199         })->count == scalar(@holdingbranches) ? 0 : 1;
200     }
201
202     return 0;
203 }
204
205
206 =head3 pickup_locations
207
208 @pickup_locations = $biblio->pickup_locations( {patron => $patron } )
209
210 Returns possible pickup locations for this biblio items, according to patron's home library (if patron is defined and holds are allowed only from hold groups)
211 and if item can be transferred to each pickup location.
212
213 =cut
214
215 sub pickup_locations {
216     my ($self, $params) = @_;
217
218     my $patron = $params->{patron};
219
220     my @pickup_locations;
221     foreach my $item_of_bib ($self->items->as_list) {
222         push @pickup_locations, $item_of_bib->pickup_locations( {patron => $patron} );
223     }
224
225     my %seen;
226     @pickup_locations =
227       grep { !$seen{ $_->branchcode }++ } @pickup_locations;
228
229     return wantarray ? @pickup_locations : \@pickup_locations;
230 }
231
232 =head3 hidden_in_opac
233
234 my $bool = $biblio->hidden_in_opac({ [ rules => $rules ] })
235
236 Returns true if the biblio matches the hidding criteria defined in $rules.
237 Returns false otherwise.
238
239 Takes HASHref that can have the following parameters:
240     OPTIONAL PARAMETERS:
241     $rules : { <field> => [ value_1, ... ], ... }
242
243 Note: $rules inherits its structure from the parsed YAML from reading
244 the I<OpacHiddenItems> system preference.
245
246 =cut
247
248 sub hidden_in_opac {
249     my ( $self, $params ) = @_;
250
251     my $rules = $params->{rules} // {};
252
253     my @items = $self->items->as_list;
254
255     return 0 unless @items; # Do not hide if there is no item
256
257     return !(any { !$_->hidden_in_opac({ rules => $rules }) } @items);
258 }
259
260 =head3 article_request_type
261
262 my $type = $biblio->article_request_type( $borrower );
263
264 Returns the article request type based on items, or on the record
265 itself if there are no items.
266
267 $borrower must be a Koha::Patron object
268
269 =cut
270
271 sub article_request_type {
272     my ( $self, $borrower ) = @_;
273
274     return q{} unless $borrower;
275
276     my $rule = $self->article_request_type_for_items( $borrower );
277     return $rule if $rule;
278
279     # If the record has no items that are requestable, go by the record itemtype
280     $rule = $self->article_request_type_for_bib($borrower);
281     return $rule if $rule;
282
283     return q{};
284 }
285
286 =head3 article_request_type_for_bib
287
288 my $type = $biblio->article_request_type_for_bib
289
290 Returns the article request type 'yes', 'no', 'item_only', 'bib_only', for the given record
291
292 =cut
293
294 sub article_request_type_for_bib {
295     my ( $self, $borrower ) = @_;
296
297     return q{} unless $borrower;
298
299     my $borrowertype = $borrower->categorycode;
300     my $itemtype     = $self->itemtype();
301
302     my $rule = Koha::CirculationRules->get_effective_rule(
303         {
304             rule_name    => 'article_requests',
305             categorycode => $borrowertype,
306             itemtype     => $itemtype,
307         }
308     );
309
310     return q{} unless $rule;
311     return $rule->rule_value || q{}
312 }
313
314 =head3 article_request_type_for_items
315
316 my $type = $biblio->article_request_type_for_items
317
318 Returns the article request type 'yes', 'no', 'item_only', 'bib_only', for the given record's items
319
320 If there is a conflict where some items are 'bib_only' and some are 'item_only', 'bib_only' will be returned.
321
322 =cut
323
324 sub article_request_type_for_items {
325     my ( $self, $borrower ) = @_;
326
327     my $counts;
328     foreach my $item ( $self->items()->as_list() ) {
329         my $rule = $item->article_request_type($borrower);
330         return $rule if $rule eq 'bib_only';    # we don't need to go any further
331         $counts->{$rule}++;
332     }
333
334     return 'item_only' if $counts->{item_only};
335     return 'yes'       if $counts->{yes};
336     return 'no'        if $counts->{no};
337     return q{};
338 }
339
340 =head3 article_requests
341
342 my @requests = $biblio->article_requests
343
344 Returns the article requests associated with this Biblio
345
346 =cut
347
348 sub article_requests {
349     my ( $self, $borrower ) = @_;
350
351     $self->{_article_requests} ||= Koha::ArticleRequests->search( { biblionumber => $self->biblionumber() } );
352
353     return wantarray ? $self->{_article_requests}->as_list : $self->{_article_requests};
354 }
355
356 =head3 article_requests_current
357
358 my @requests = $biblio->article_requests_current
359
360 Returns the article requests associated with this Biblio that are incomplete
361
362 =cut
363
364 sub article_requests_current {
365     my ( $self, $borrower ) = @_;
366
367     $self->{_article_requests_current} ||= Koha::ArticleRequests->search(
368         {
369             biblionumber => $self->biblionumber(),
370             -or          => [
371                 { status => Koha::ArticleRequest::Status::Pending },
372                 { status => Koha::ArticleRequest::Status::Processing }
373             ]
374         }
375     );
376
377     return wantarray ? $self->{_article_requests_current}->as_list : $self->{_article_requests_current};
378 }
379
380 =head3 article_requests_finished
381
382 my @requests = $biblio->article_requests_finished
383
384 Returns the article requests associated with this Biblio that are completed
385
386 =cut
387
388 sub article_requests_finished {
389     my ( $self, $borrower ) = @_;
390
391     $self->{_article_requests_finished} ||= Koha::ArticleRequests->search(
392         {
393             biblionumber => $self->biblionumber(),
394             -or          => [
395                 { status => Koha::ArticleRequest::Status::Completed },
396                 { status => Koha::ArticleRequest::Status::Canceled }
397             ]
398         }
399     );
400
401     return wantarray ? $self->{_article_requests_finished}->as_list : $self->{_article_requests_finished};
402 }
403
404 =head3 items
405
406 my $items = $biblio->items();
407
408 Returns the related Koha::Items object for this biblio
409
410 =cut
411
412 sub items {
413     my ($self) = @_;
414
415     my $items_rs = $self->_result->items;
416
417     return Koha::Items->_new_from_dbic( $items_rs );
418 }
419
420 =head3 itemtype
421
422 my $itemtype = $biblio->itemtype();
423
424 Returns the itemtype for this record.
425
426 =cut
427
428 sub itemtype {
429     my ( $self ) = @_;
430
431     return $self->biblioitem()->itemtype();
432 }
433
434 =head3 holds
435
436 my $holds = $biblio->holds();
437
438 return the current holds placed on this record
439
440 =cut
441
442 sub holds {
443     my ( $self, $params, $attributes ) = @_;
444     $attributes->{order_by} = 'priority' unless exists $attributes->{order_by};
445     my $hold_rs = $self->_result->reserves->search( $params, $attributes );
446     return Koha::Holds->_new_from_dbic($hold_rs);
447 }
448
449 =head3 current_holds
450
451 my $holds = $biblio->current_holds
452
453 Return the holds placed on this bibliographic record.
454 It does not include future holds.
455
456 =cut
457
458 sub current_holds {
459     my ($self) = @_;
460     my $dtf = Koha::Database->new->schema->storage->datetime_parser;
461     return $self->holds(
462         { reservedate => { '<=' => $dtf->format_date(dt_from_string) } } );
463 }
464
465 =head3 biblioitem
466
467 my $field = $self->biblioitem()->itemtype
468
469 Returns the related Koha::Biblioitem object for this Biblio object
470
471 =cut
472
473 sub biblioitem {
474     my ($self) = @_;
475
476     $self->{_biblioitem} ||= Koha::Biblioitems->find( { biblionumber => $self->biblionumber() } );
477
478     return $self->{_biblioitem};
479 }
480
481 =head3 suggestions
482
483 my $suggestions = $self->suggestions
484
485 Returns the related Koha::Suggestions object for this Biblio object
486
487 =cut
488
489 sub suggestions {
490     my ($self) = @_;
491
492     my $suggestions_rs = $self->_result->suggestions;
493     return Koha::Suggestions->_new_from_dbic( $suggestions_rs );
494 }
495
496 =head3 subscriptions
497
498 my $subscriptions = $self->subscriptions
499
500 Returns the related Koha::Subscriptions object for this Biblio object
501
502 =cut
503
504 sub subscriptions {
505     my ($self) = @_;
506
507     $self->{_subscriptions} ||= Koha::Subscriptions->search( { biblionumber => $self->biblionumber } );
508
509     return $self->{_subscriptions};
510 }
511
512 =head3 has_items_waiting_or_intransit
513
514 my $itemsWaitingOrInTransit = $biblio->has_items_waiting_or_intransit
515
516 Tells if this bibliographic record has items waiting or in transit.
517
518 =cut
519
520 sub has_items_waiting_or_intransit {
521     my ( $self ) = @_;
522
523     if ( Koha::Holds->search({ biblionumber => $self->id,
524                                found => ['W', 'T'] })->count ) {
525         return 1;
526     }
527
528     foreach my $item ( $self->items->as_list ) {
529         return 1 if $item->get_transfer;
530     }
531
532     return 0;
533 }
534
535 =head2 get_coins
536
537 my $coins = $biblio->get_coins;
538
539 Returns the COinS (a span) which can be included in a biblio record
540
541 =cut
542
543 sub get_coins {
544     my ( $self ) = @_;
545
546     my $record = $self->metadata->record;
547
548     my $pos7 = substr $record->leader(), 7, 1;
549     my $pos6 = substr $record->leader(), 6, 1;
550     my $mtx;
551     my $genre;
552     my ( $aulast, $aufirst ) = ( '', '' );
553     my @authors;
554     my $title;
555     my $hosttitle;
556     my $pubyear   = '';
557     my $isbn      = '';
558     my $issn      = '';
559     my $publisher = '';
560     my $pages     = '';
561     my $titletype = '';
562
563     # For the purposes of generating COinS metadata, LDR/06-07 can be
564     # considered the same for UNIMARC and MARC21
565     my $fmts6 = {
566         'a' => 'book',
567         'b' => 'manuscript',
568         'c' => 'book',
569         'd' => 'manuscript',
570         'e' => 'map',
571         'f' => 'map',
572         'g' => 'film',
573         'i' => 'audioRecording',
574         'j' => 'audioRecording',
575         'k' => 'artwork',
576         'l' => 'document',
577         'm' => 'computerProgram',
578         'o' => 'document',
579         'r' => 'document',
580     };
581     my $fmts7 = {
582         'a' => 'journalArticle',
583         's' => 'journal',
584     };
585
586     $genre = $fmts6->{$pos6} ? $fmts6->{$pos6} : 'book';
587
588     if ( $genre eq 'book' ) {
589             $genre = $fmts7->{$pos7} if $fmts7->{$pos7};
590     }
591
592     ##### We must transform mtx to a valable mtx and document type ####
593     if ( $genre eq 'book' ) {
594             $mtx = 'book';
595             $titletype = 'b';
596     } elsif ( $genre eq 'journal' ) {
597             $mtx = 'journal';
598             $titletype = 'j';
599     } elsif ( $genre eq 'journalArticle' ) {
600             $mtx   = 'journal';
601             $genre = 'article';
602             $titletype = 'a';
603     } else {
604             $mtx = 'dc';
605     }
606
607     if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
608
609         # Setting datas
610         $aulast  = $record->subfield( '700', 'a' ) || '';
611         $aufirst = $record->subfield( '700', 'b' ) || '';
612         push @authors, "$aufirst $aulast" if ($aufirst or $aulast);
613
614         # others authors
615         if ( $record->field('200') ) {
616             for my $au ( $record->field('200')->subfield('g') ) {
617                 push @authors, $au;
618             }
619         }
620
621         $title     = $record->subfield( '200', 'a' );
622         my $subfield_210d = $record->subfield('210', 'd');
623         if ($subfield_210d and $subfield_210d =~ /(\d{4})/) {
624             $pubyear = $1;
625         }
626         $publisher = $record->subfield( '210', 'c' ) || '';
627         $isbn      = $record->subfield( '010', 'a' ) || '';
628         $issn      = $record->subfield( '011', 'a' ) || '';
629     } else {
630
631         # MARC21 need some improve
632
633         # Setting datas
634         if ( $record->field('100') ) {
635             push @authors, $record->subfield( '100', 'a' );
636         }
637
638         # others authors
639         if ( $record->field('700') ) {
640             for my $au ( $record->field('700')->subfield('a') ) {
641                 push @authors, $au;
642             }
643         }
644         $title = $record->field('245')->as_string('ab');
645         if ($titletype eq 'a') {
646             $pubyear   = $record->field('008') || '';
647             $pubyear   = substr($pubyear->data(), 7, 4) if $pubyear;
648             $isbn      = $record->subfield( '773', 'z' ) || '';
649             $issn      = $record->subfield( '773', 'x' ) || '';
650             $hosttitle = $record->subfield( '773', 't' ) || $record->subfield( '773', 'a') || q{};
651             my @rels = $record->subfield( '773', 'g' );
652             $pages = join(', ', @rels);
653         } else {
654             $pubyear   = $record->subfield( '260', 'c' ) || '';
655             $publisher = $record->subfield( '260', 'b' ) || '';
656             $isbn      = $record->subfield( '020', 'a' ) || '';
657             $issn      = $record->subfield( '022', 'a' ) || '';
658         }
659
660     }
661
662     my @params = (
663         [ 'ctx_ver', 'Z39.88-2004' ],
664         [ 'rft_val_fmt', "info:ofi/fmt:kev:mtx:$mtx" ],
665         [ ($mtx eq 'dc' ? 'rft.type' : 'rft.genre'), $genre ],
666         [ "rft.${titletype}title", $title ],
667     );
668
669     # rft.title is authorized only once, so by checking $titletype
670     # we ensure that rft.title is not already in the list.
671     if ($hosttitle and $titletype) {
672         push @params, [ 'rft.title', $hosttitle ];
673     }
674
675     push @params, (
676         [ 'rft.isbn', $isbn ],
677         [ 'rft.issn', $issn ],
678     );
679
680     # If it's a subscription, these informations have no meaning.
681     if ($genre ne 'journal') {
682         push @params, (
683             [ 'rft.aulast', $aulast ],
684             [ 'rft.aufirst', $aufirst ],
685             (map { [ 'rft.au', $_ ] } @authors),
686             [ 'rft.pub', $publisher ],
687             [ 'rft.date', $pubyear ],
688             [ 'rft.pages', $pages ],
689         );
690     }
691
692     my $coins_value = join( '&amp;',
693         map { $$_[1] ? $$_[0] . '=' . uri_escape_utf8( $$_[1] ) : () } @params );
694
695     return $coins_value;
696 }
697
698 =head2 get_openurl
699
700 my $url = $biblio->get_openurl;
701
702 Returns url for OpenURL resolver set in OpenURLResolverURL system preference
703
704 =cut
705
706 sub get_openurl {
707     my ( $self ) = @_;
708
709     my $OpenURLResolverURL = C4::Context->preference('OpenURLResolverURL');
710
711     if ($OpenURLResolverURL) {
712         my $uri = URI->new($OpenURLResolverURL);
713
714         if (not defined $uri->query) {
715             $OpenURLResolverURL .= '?';
716         } else {
717             $OpenURLResolverURL .= '&amp;';
718         }
719         $OpenURLResolverURL .= $self->get_coins;
720     }
721
722     return $OpenURLResolverURL;
723 }
724
725 =head3 is_serial
726
727 my $serial = $biblio->is_serial
728
729 Return boolean true if this bibbliographic record is continuing resource
730
731 =cut
732
733 sub is_serial {
734     my ( $self ) = @_;
735
736     return 1 if $self->serial;
737
738     my $record = $self->metadata->record;
739     return 1 if substr($record->leader, 7, 1) eq 's';
740
741     return 0;
742 }
743
744 =head3 custom_cover_image_url
745
746 my $image_url = $biblio->custom_cover_image_url
747
748 Return the specific url of the cover image for this bibliographic record.
749 It is built regaring the value of the system preference CustomCoverImagesURL
750
751 =cut
752
753 sub custom_cover_image_url {
754     my ( $self ) = @_;
755     my $url = C4::Context->preference('CustomCoverImagesURL');
756     if ( $url =~ m|{isbn}| ) {
757         my $isbn = $self->biblioitem->isbn;
758         $url =~ s|{isbn}|$isbn|g;
759     }
760     if ( $url =~ m|{normalized_isbn}| ) {
761         my $normalized_isbn = C4::Koha::GetNormalizedISBN($self->biblioitem->isbn);
762         $url =~ s|{normalized_isbn}|$normalized_isbn|g;
763     }
764     if ( $url =~ m|{issn}| ) {
765         my $issn = $self->biblioitem->issn;
766         $url =~ s|{issn}|$issn|g;
767     }
768
769     my $re = qr|{(?<field>\d{3})\$(?<subfield>.)}|;
770     if ( $url =~ $re ) {
771         my $field = $+{field};
772         my $subfield = $+{subfield};
773         my $marc_record = $self->metadata->record;
774         my $value = $marc_record->subfield($field, $subfield);
775         $url =~ s|$re|$value|;
776     }
777
778     return $url;
779 }
780
781 =head3 to_api
782
783     my $json = $biblio->to_api;
784
785 Overloaded method that returns a JSON representation of the Koha::Biblio object,
786 suitable for API output. The related Koha::Biblioitem object is merged as expected
787 on the API.
788
789 =cut
790
791 sub to_api {
792     my ($self, $args) = @_;
793
794     my $response = $self->SUPER::to_api( $args );
795     my $biblioitem = $self->biblioitem->to_api;
796
797     return { %$response, %$biblioitem };
798 }
799
800 =head3 to_api_mapping
801
802 This method returns the mapping for representing a Koha::Biblio object
803 on the API.
804
805 =cut
806
807 sub to_api_mapping {
808     return {
809         biblionumber     => 'biblio_id',
810         frameworkcode    => 'framework_id',
811         unititle         => 'uniform_title',
812         seriestitle      => 'series_title',
813         copyrightdate    => 'copyright_date',
814         datecreated      => 'creation_date'
815     };
816 }
817
818 =head2 Internal methods
819
820 =head3 type
821
822 =cut
823
824 sub _type {
825     return 'Biblio';
826 }
827
828 =head1 AUTHOR
829
830 Kyle M Hall <kyle@bywatersolutions.com>
831
832 =cut
833
834 1;