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