Bug 18501: (follow-up) Do not rely on userenv->{branchcode}
[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     my $pickup_locations = $biblio->pickup_locations( {patron => $patron } );
209
210 Returns an I<arrayref> of possible pickup locations for this biblio's items,
211 according to patron's home library (if patron is defined and holds are allowed
212 only from hold groups) and if item can be transferred to each pickup location.
213
214 =cut
215
216 sub pickup_locations {
217     my ($self, $params) = @_;
218
219     my $patron = $params->{patron};
220
221     my @pickup_locations;
222     foreach my $item_of_bib ($self->items->as_list) {
223         push @pickup_locations, @{ $item_of_bib->pickup_locations( {patron => $patron} ) };
224     }
225
226     my %seen;
227     @pickup_locations =
228       grep { !$seen{ $_->branchcode }++ } @pickup_locations;
229
230     return \@pickup_locations;
231 }
232
233 =head3 hidden_in_opac
234
235 my $bool = $biblio->hidden_in_opac({ [ rules => $rules ] })
236
237 Returns true if the biblio matches the hidding criteria defined in $rules.
238 Returns false otherwise.
239
240 Takes HASHref that can have the following parameters:
241     OPTIONAL PARAMETERS:
242     $rules : { <field> => [ value_1, ... ], ... }
243
244 Note: $rules inherits its structure from the parsed YAML from reading
245 the I<OpacHiddenItems> system preference.
246
247 =cut
248
249 sub hidden_in_opac {
250     my ( $self, $params ) = @_;
251
252     my $rules = $params->{rules} // {};
253
254     my @items = $self->items->as_list;
255
256     return 0 unless @items; # Do not hide if there is no item
257
258     return !(any { !$_->hidden_in_opac({ rules => $rules }) } @items);
259 }
260
261 =head3 article_request_type
262
263 my $type = $biblio->article_request_type( $borrower );
264
265 Returns the article request type based on items, or on the record
266 itself if there are no items.
267
268 $borrower must be a Koha::Patron object
269
270 =cut
271
272 sub article_request_type {
273     my ( $self, $borrower ) = @_;
274
275     return q{} unless $borrower;
276
277     my $rule = $self->article_request_type_for_items( $borrower );
278     return $rule if $rule;
279
280     # If the record has no items that are requestable, go by the record itemtype
281     $rule = $self->article_request_type_for_bib($borrower);
282     return $rule if $rule;
283
284     return q{};
285 }
286
287 =head3 article_request_type_for_bib
288
289 my $type = $biblio->article_request_type_for_bib
290
291 Returns the article request type 'yes', 'no', 'item_only', 'bib_only', for the given record
292
293 =cut
294
295 sub article_request_type_for_bib {
296     my ( $self, $borrower ) = @_;
297
298     return q{} unless $borrower;
299
300     my $borrowertype = $borrower->categorycode;
301     my $itemtype     = $self->itemtype();
302
303     my $rule = Koha::CirculationRules->get_effective_rule(
304         {
305             rule_name    => 'article_requests',
306             categorycode => $borrowertype,
307             itemtype     => $itemtype,
308         }
309     );
310
311     return q{} unless $rule;
312     return $rule->rule_value || q{}
313 }
314
315 =head3 article_request_type_for_items
316
317 my $type = $biblio->article_request_type_for_items
318
319 Returns the article request type 'yes', 'no', 'item_only', 'bib_only', for the given record's items
320
321 If there is a conflict where some items are 'bib_only' and some are 'item_only', 'bib_only' will be returned.
322
323 =cut
324
325 sub article_request_type_for_items {
326     my ( $self, $borrower ) = @_;
327
328     my $counts;
329     foreach my $item ( $self->items()->as_list() ) {
330         my $rule = $item->article_request_type($borrower);
331         return $rule if $rule eq 'bib_only';    # we don't need to go any further
332         $counts->{$rule}++;
333     }
334
335     return 'item_only' if $counts->{item_only};
336     return 'yes'       if $counts->{yes};
337     return 'no'        if $counts->{no};
338     return q{};
339 }
340
341 =head3 article_requests
342
343 my @requests = $biblio->article_requests
344
345 Returns the article requests associated with this Biblio
346
347 =cut
348
349 sub article_requests {
350     my ( $self, $borrower ) = @_;
351
352     $self->{_article_requests} ||= Koha::ArticleRequests->search( { biblionumber => $self->biblionumber() } );
353
354     return wantarray ? $self->{_article_requests}->as_list : $self->{_article_requests};
355 }
356
357 =head3 article_requests_current
358
359 my @requests = $biblio->article_requests_current
360
361 Returns the article requests associated with this Biblio that are incomplete
362
363 =cut
364
365 sub article_requests_current {
366     my ( $self, $borrower ) = @_;
367
368     $self->{_article_requests_current} ||= Koha::ArticleRequests->search(
369         {
370             biblionumber => $self->biblionumber(),
371             -or          => [
372                 { status => Koha::ArticleRequest::Status::Pending },
373                 { status => Koha::ArticleRequest::Status::Processing }
374             ]
375         }
376     );
377
378     return wantarray ? $self->{_article_requests_current}->as_list : $self->{_article_requests_current};
379 }
380
381 =head3 article_requests_finished
382
383 my @requests = $biblio->article_requests_finished
384
385 Returns the article requests associated with this Biblio that are completed
386
387 =cut
388
389 sub article_requests_finished {
390     my ( $self, $borrower ) = @_;
391
392     $self->{_article_requests_finished} ||= Koha::ArticleRequests->search(
393         {
394             biblionumber => $self->biblionumber(),
395             -or          => [
396                 { status => Koha::ArticleRequest::Status::Completed },
397                 { status => Koha::ArticleRequest::Status::Canceled }
398             ]
399         }
400     );
401
402     return wantarray ? $self->{_article_requests_finished}->as_list : $self->{_article_requests_finished};
403 }
404
405 =head3 items
406
407 my $items = $biblio->items();
408
409 Returns the related Koha::Items object for this biblio
410
411 =cut
412
413 sub items {
414     my ($self) = @_;
415
416     my $items_rs = $self->_result->items;
417
418     return Koha::Items->_new_from_dbic( $items_rs );
419 }
420
421 =head3 itemtype
422
423 my $itemtype = $biblio->itemtype();
424
425 Returns the itemtype for this record.
426
427 =cut
428
429 sub itemtype {
430     my ( $self ) = @_;
431
432     return $self->biblioitem()->itemtype();
433 }
434
435 =head3 holds
436
437 my $holds = $biblio->holds();
438
439 return the current holds placed on this record
440
441 =cut
442
443 sub holds {
444     my ( $self, $params, $attributes ) = @_;
445     $attributes->{order_by} = 'priority' unless exists $attributes->{order_by};
446     my $hold_rs = $self->_result->reserves->search( $params, $attributes );
447     return Koha::Holds->_new_from_dbic($hold_rs);
448 }
449
450 =head3 current_holds
451
452 my $holds = $biblio->current_holds
453
454 Return the holds placed on this bibliographic record.
455 It does not include future holds.
456
457 =cut
458
459 sub current_holds {
460     my ($self) = @_;
461     my $dtf = Koha::Database->new->schema->storage->datetime_parser;
462     return $self->holds(
463         { reservedate => { '<=' => $dtf->format_date(dt_from_string) } } );
464 }
465
466 =head3 biblioitem
467
468 my $field = $self->biblioitem()->itemtype
469
470 Returns the related Koha::Biblioitem object for this Biblio object
471
472 =cut
473
474 sub biblioitem {
475     my ($self) = @_;
476
477     $self->{_biblioitem} ||= Koha::Biblioitems->find( { biblionumber => $self->biblionumber() } );
478
479     return $self->{_biblioitem};
480 }
481
482 =head3 suggestions
483
484 my $suggestions = $self->suggestions
485
486 Returns the related Koha::Suggestions object for this Biblio object
487
488 =cut
489
490 sub suggestions {
491     my ($self) = @_;
492
493     my $suggestions_rs = $self->_result->suggestions;
494     return Koha::Suggestions->_new_from_dbic( $suggestions_rs );
495 }
496
497 =head3 subscriptions
498
499 my $subscriptions = $self->subscriptions
500
501 Returns the related Koha::Subscriptions object for this Biblio object
502
503 =cut
504
505 sub subscriptions {
506     my ($self) = @_;
507
508     $self->{_subscriptions} ||= Koha::Subscriptions->search( { biblionumber => $self->biblionumber } );
509
510     return $self->{_subscriptions};
511 }
512
513 =head3 has_items_waiting_or_intransit
514
515 my $itemsWaitingOrInTransit = $biblio->has_items_waiting_or_intransit
516
517 Tells if this bibliographic record has items waiting or in transit.
518
519 =cut
520
521 sub has_items_waiting_or_intransit {
522     my ( $self ) = @_;
523
524     if ( Koha::Holds->search({ biblionumber => $self->id,
525                                found => ['W', 'T'] })->count ) {
526         return 1;
527     }
528
529     foreach my $item ( $self->items->as_list ) {
530         return 1 if $item->get_transfer;
531     }
532
533     return 0;
534 }
535
536 =head2 get_coins
537
538 my $coins = $biblio->get_coins;
539
540 Returns the COinS (a span) which can be included in a biblio record
541
542 =cut
543
544 sub get_coins {
545     my ( $self ) = @_;
546
547     my $record = $self->metadata->record;
548
549     my $pos7 = substr $record->leader(), 7, 1;
550     my $pos6 = substr $record->leader(), 6, 1;
551     my $mtx;
552     my $genre;
553     my ( $aulast, $aufirst ) = ( '', '' );
554     my @authors;
555     my $title;
556     my $hosttitle;
557     my $pubyear   = '';
558     my $isbn      = '';
559     my $issn      = '';
560     my $publisher = '';
561     my $pages     = '';
562     my $titletype = '';
563
564     # For the purposes of generating COinS metadata, LDR/06-07 can be
565     # considered the same for UNIMARC and MARC21
566     my $fmts6 = {
567         'a' => 'book',
568         'b' => 'manuscript',
569         'c' => 'book',
570         'd' => 'manuscript',
571         'e' => 'map',
572         'f' => 'map',
573         'g' => 'film',
574         'i' => 'audioRecording',
575         'j' => 'audioRecording',
576         'k' => 'artwork',
577         'l' => 'document',
578         'm' => 'computerProgram',
579         'o' => 'document',
580         'r' => 'document',
581     };
582     my $fmts7 = {
583         'a' => 'journalArticle',
584         's' => 'journal',
585     };
586
587     $genre = $fmts6->{$pos6} ? $fmts6->{$pos6} : 'book';
588
589     if ( $genre eq 'book' ) {
590             $genre = $fmts7->{$pos7} if $fmts7->{$pos7};
591     }
592
593     ##### We must transform mtx to a valable mtx and document type ####
594     if ( $genre eq 'book' ) {
595             $mtx = 'book';
596             $titletype = 'b';
597     } elsif ( $genre eq 'journal' ) {
598             $mtx = 'journal';
599             $titletype = 'j';
600     } elsif ( $genre eq 'journalArticle' ) {
601             $mtx   = 'journal';
602             $genre = 'article';
603             $titletype = 'a';
604     } else {
605             $mtx = 'dc';
606     }
607
608     if ( C4::Context->preference("marcflavour") eq "UNIMARC" ) {
609
610         # Setting datas
611         $aulast  = $record->subfield( '700', 'a' ) || '';
612         $aufirst = $record->subfield( '700', 'b' ) || '';
613         push @authors, "$aufirst $aulast" if ($aufirst or $aulast);
614
615         # others authors
616         if ( $record->field('200') ) {
617             for my $au ( $record->field('200')->subfield('g') ) {
618                 push @authors, $au;
619             }
620         }
621
622         $title     = $record->subfield( '200', 'a' );
623         my $subfield_210d = $record->subfield('210', 'd');
624         if ($subfield_210d and $subfield_210d =~ /(\d{4})/) {
625             $pubyear = $1;
626         }
627         $publisher = $record->subfield( '210', 'c' ) || '';
628         $isbn      = $record->subfield( '010', 'a' ) || '';
629         $issn      = $record->subfield( '011', 'a' ) || '';
630     } else {
631
632         # MARC21 need some improve
633
634         # Setting datas
635         if ( $record->field('100') ) {
636             push @authors, $record->subfield( '100', 'a' );
637         }
638
639         # others authors
640         if ( $record->field('700') ) {
641             for my $au ( $record->field('700')->subfield('a') ) {
642                 push @authors, $au;
643             }
644         }
645         $title = $record->field('245')->as_string('ab');
646         if ($titletype eq 'a') {
647             $pubyear   = $record->field('008') || '';
648             $pubyear   = substr($pubyear->data(), 7, 4) if $pubyear;
649             $isbn      = $record->subfield( '773', 'z' ) || '';
650             $issn      = $record->subfield( '773', 'x' ) || '';
651             $hosttitle = $record->subfield( '773', 't' ) || $record->subfield( '773', 'a') || q{};
652             my @rels = $record->subfield( '773', 'g' );
653             $pages = join(', ', @rels);
654         } else {
655             $pubyear   = $record->subfield( '260', 'c' ) || '';
656             $publisher = $record->subfield( '260', 'b' ) || '';
657             $isbn      = $record->subfield( '020', 'a' ) || '';
658             $issn      = $record->subfield( '022', 'a' ) || '';
659         }
660
661     }
662
663     my @params = (
664         [ 'ctx_ver', 'Z39.88-2004' ],
665         [ 'rft_val_fmt', "info:ofi/fmt:kev:mtx:$mtx" ],
666         [ ($mtx eq 'dc' ? 'rft.type' : 'rft.genre'), $genre ],
667         [ "rft.${titletype}title", $title ],
668     );
669
670     # rft.title is authorized only once, so by checking $titletype
671     # we ensure that rft.title is not already in the list.
672     if ($hosttitle and $titletype) {
673         push @params, [ 'rft.title', $hosttitle ];
674     }
675
676     push @params, (
677         [ 'rft.isbn', $isbn ],
678         [ 'rft.issn', $issn ],
679     );
680
681     # If it's a subscription, these informations have no meaning.
682     if ($genre ne 'journal') {
683         push @params, (
684             [ 'rft.aulast', $aulast ],
685             [ 'rft.aufirst', $aufirst ],
686             (map { [ 'rft.au', $_ ] } @authors),
687             [ 'rft.pub', $publisher ],
688             [ 'rft.date', $pubyear ],
689             [ 'rft.pages', $pages ],
690         );
691     }
692
693     my $coins_value = join( '&amp;',
694         map { $$_[1] ? $$_[0] . '=' . uri_escape_utf8( $$_[1] ) : () } @params );
695
696     return $coins_value;
697 }
698
699 =head2 get_openurl
700
701 my $url = $biblio->get_openurl;
702
703 Returns url for OpenURL resolver set in OpenURLResolverURL system preference
704
705 =cut
706
707 sub get_openurl {
708     my ( $self ) = @_;
709
710     my $OpenURLResolverURL = C4::Context->preference('OpenURLResolverURL');
711
712     if ($OpenURLResolverURL) {
713         my $uri = URI->new($OpenURLResolverURL);
714
715         if (not defined $uri->query) {
716             $OpenURLResolverURL .= '?';
717         } else {
718             $OpenURLResolverURL .= '&amp;';
719         }
720         $OpenURLResolverURL .= $self->get_coins;
721     }
722
723     return $OpenURLResolverURL;
724 }
725
726 =head3 is_serial
727
728 my $serial = $biblio->is_serial
729
730 Return boolean true if this bibbliographic record is continuing resource
731
732 =cut
733
734 sub is_serial {
735     my ( $self ) = @_;
736
737     return 1 if $self->serial;
738
739     my $record = $self->metadata->record;
740     return 1 if substr($record->leader, 7, 1) eq 's';
741
742     return 0;
743 }
744
745 =head3 custom_cover_image_url
746
747 my $image_url = $biblio->custom_cover_image_url
748
749 Return the specific url of the cover image for this bibliographic record.
750 It is built regaring the value of the system preference CustomCoverImagesURL
751
752 =cut
753
754 sub custom_cover_image_url {
755     my ( $self ) = @_;
756     my $url = C4::Context->preference('CustomCoverImagesURL');
757     if ( $url =~ m|{isbn}| ) {
758         my $isbn = $self->biblioitem->isbn;
759         $url =~ s|{isbn}|$isbn|g;
760     }
761     if ( $url =~ m|{normalized_isbn}| ) {
762         my $normalized_isbn = C4::Koha::GetNormalizedISBN($self->biblioitem->isbn);
763         $url =~ s|{normalized_isbn}|$normalized_isbn|g;
764     }
765     if ( $url =~ m|{issn}| ) {
766         my $issn = $self->biblioitem->issn;
767         $url =~ s|{issn}|$issn|g;
768     }
769
770     my $re = qr|{(?<field>\d{3})\$(?<subfield>.)}|;
771     if ( $url =~ $re ) {
772         my $field = $+{field};
773         my $subfield = $+{subfield};
774         my $marc_record = $self->metadata->record;
775         my $value = $marc_record->subfield($field, $subfield);
776         $url =~ s|$re|$value|;
777     }
778
779     return $url;
780 }
781
782 =head3 to_api
783
784     my $json = $biblio->to_api;
785
786 Overloaded method that returns a JSON representation of the Koha::Biblio object,
787 suitable for API output. The related Koha::Biblioitem object is merged as expected
788 on the API.
789
790 =cut
791
792 sub to_api {
793     my ($self, $args) = @_;
794
795     my $response = $self->SUPER::to_api( $args );
796     my $biblioitem = $self->biblioitem->to_api;
797
798     return { %$response, %$biblioitem };
799 }
800
801 =head3 to_api_mapping
802
803 This method returns the mapping for representing a Koha::Biblio object
804 on the API.
805
806 =cut
807
808 sub to_api_mapping {
809     return {
810         biblionumber     => 'biblio_id',
811         frameworkcode    => 'framework_id',
812         unititle         => 'uniform_title',
813         seriestitle      => 'series_title',
814         copyrightdate    => 'copyright_date',
815         datecreated      => 'creation_date'
816     };
817 }
818
819 =head2 Internal methods
820
821 =head3 type
822
823 =cut
824
825 sub _type {
826     return 'Biblio';
827 }
828
829 =head1 AUTHOR
830
831 Kyle M Hall <kyle@bywatersolutions.com>
832
833 =cut
834
835 1;