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