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