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