Bug 26313: (follow-up) Fix OPAC and "Show volumes" links
[koha.git] / C4 / Suggestions.pm
blob11cbf96fb76ff25fd2422ed029592a4624c386d1
1 package C4::Suggestions;
3 # Copyright 2000-2002 Katipo Communications
4 # Parts Copyright Biblibre 2011
6 # This file is part of Koha.
8 # Koha is free software; you can redistribute it and/or modify it
9 # under the terms of the GNU General Public License as published by
10 # the Free Software Foundation; either version 3 of the License, or
11 # (at your option) any later version.
13 # Koha is distributed in the hope that it will be useful, but
14 # WITHOUT ANY WARRANTY; without even the implied warranty of
15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 # GNU General Public License for more details.
18 # You should have received a copy of the GNU General Public License
19 # along with Koha; if not, see <http://www.gnu.org/licenses>.
21 use Modern::Perl;
22 use CGI qw ( -utf8 );
24 use C4::Context;
25 use C4::Output;
26 use C4::Debug;
27 use C4::Letters;
28 use C4::Biblio qw( GetMarcFromKohaField );
29 use Koha::DateUtils;
30 use Koha::Suggestions;
32 use List::MoreUtils qw(any);
33 use base qw(Exporter);
35 our @EXPORT = qw(
36 ConnectSuggestionAndBiblio
37 DelSuggestion
38 GetSuggestion
39 GetSuggestionByStatus
40 GetSuggestionFromBiblionumber
41 GetSuggestionInfoFromBiblionumber
42 GetSuggestionInfo
43 ModStatus
44 ModSuggestion
45 NewSuggestion
46 SearchSuggestion
47 DelSuggestionsOlderThan
48 GetUnprocessedSuggestions
49 MarcRecordFromNewSuggestion
52 =head1 NAME
54 C4::Suggestions - Some useful functions for dealings with aqorders.
56 =head1 SYNOPSIS
58 use C4::Suggestions;
60 =head1 DESCRIPTION
62 The functions in this module deal with the aqorders in OPAC and in librarian interface
64 A suggestion is done in the OPAC. It has the status "ASKED"
66 When a librarian manages the suggestion, they can set the status to "REJECTED" or "ACCEPTED".
68 When the book is ordered, the suggestion status becomes "ORDERED"
70 When a book is ordered and arrived in the library, the status becomes "AVAILABLE"
72 All aqorders of a borrower can be seen by the borrower itself.
73 Suggestions done by other borrowers can be seen when not "AVAILABLE"
75 =head1 FUNCTIONS
77 =head2 SearchSuggestion
79 (\@array) = &SearchSuggestion($suggestionhashref_to_search)
81 searches for a suggestion
83 return :
84 C<\@array> : the aqorders found. Array of hash.
85 Note the status is stored twice :
86 * in the status field
87 * as parameter ( for example ASKED => 1, or REJECTED => 1) . This is for template & translation purposes.
89 =cut
91 sub SearchSuggestion {
92 my ($suggestion) = @_;
93 my $dbh = C4::Context->dbh;
94 my @sql_params;
95 my @query = (
97 SELECT suggestions.*,
98 U1.branchcode AS branchcodesuggestedby,
99 B1.branchname AS branchnamesuggestedby,
100 U1.surname AS surnamesuggestedby,
101 U1.firstname AS firstnamesuggestedby,
102 U1.cardnumber AS cardnumbersuggestedby,
103 U1.email AS emailsuggestedby,
104 U1.borrowernumber AS borrnumsuggestedby,
105 U1.categorycode AS categorycodesuggestedby,
106 C1.description AS categorydescriptionsuggestedby,
107 U2.surname AS surnamemanagedby,
108 U2.firstname AS firstnamemanagedby,
109 B2.branchname AS branchnamesuggestedby,
110 U2.email AS emailmanagedby,
111 U2.branchcode AS branchcodemanagedby,
112 U2.borrowernumber AS borrnummanagedby,
113 U3.surname AS surnamelastmodificationby,
114 U3.firstname AS firstnamelastmodificationby,
115 BU.budget_name AS budget_name
116 FROM suggestions
117 LEFT JOIN borrowers AS U1 ON suggestedby=U1.borrowernumber
118 LEFT JOIN branches AS B1 ON B1.branchcode=U1.branchcode
119 LEFT JOIN categories AS C1 ON C1.categorycode=U1.categorycode
120 LEFT JOIN borrowers AS U2 ON managedby=U2.borrowernumber
121 LEFT JOIN branches AS B2 ON B2.branchcode=U2.branchcode
122 LEFT JOIN categories AS C2 ON C2.categorycode=U2.categorycode
123 LEFT JOIN borrowers AS U3 ON lastmodificationby=U3.borrowernumber
124 LEFT JOIN aqbudgets AS BU ON budgetid=BU.budget_id
125 WHERE 1=1
129 # filter on biblio informations
130 foreach my $field (
131 qw( title author isbn publishercode copyrightdate collectiontitle ))
133 if ( $suggestion->{$field} ) {
134 push @sql_params, '%' . $suggestion->{$field} . '%';
135 push @query, qq{ AND suggestions.$field LIKE ? };
139 # filter on user branch
140 if ( C4::Context->preference('IndependentBranches')
141 && !C4::Context->IsSuperLibrarian() )
143 # If IndependentBranches is set and the logged in user is not superlibrarian
144 # Then we want to filter by the user's library (i.e. cannot see suggestions from other libraries)
145 my $userenv = C4::Context->userenv;
146 if ($userenv) {
148 push @sql_params, $$userenv{branch};
149 push @query, q{
150 AND (suggestions.branchcode=? OR suggestions.branchcode='')
155 elsif (defined $suggestion->{branchcode}
156 && $suggestion->{branchcode}
157 && $suggestion->{branchcode} ne '__ANY__' )
159 # If IndependentBranches is not set OR the logged in user is not superlibrarian
160 # AND the branchcode filter is passed and not '__ANY__'
161 # Then we want to filter using this parameter
162 push @sql_params, $suggestion->{branchcode};
163 push @query, qq{ AND suggestions.branchcode=? };
166 # filter on nillable fields
167 foreach my $field (
168 qw( STATUS itemtype suggestedby managedby acceptedby budgetid biblionumber )
171 if ( exists $suggestion->{$field}
172 and defined $suggestion->{$field}
173 and $suggestion->{$field} ne '__ANY__'
174 and (
175 $suggestion->{$field} ne q||
176 or $field eq 'STATUS'
179 if ( $suggestion->{$field} eq '__NONE__' ) {
180 push @query, qq{ AND (suggestions.$field = '' OR suggestions.$field IS NULL) };
182 else {
183 push @sql_params, $suggestion->{$field};
184 push @query, qq{ AND suggestions.$field = ? };
189 # filter on date fields
190 foreach my $field (qw( suggesteddate manageddate accepteddate )) {
191 my $from = $field . "_from";
192 my $to = $field . "_to";
193 my $from_dt;
194 $from_dt = eval { dt_from_string( $suggestion->{$from} ) } if ( $suggestion->{$from} );
195 my $from_sql = '0000-00-00';
196 $from_sql = output_pref({ dt => $from_dt, dateformat => 'iso', dateonly => 1 })
197 if ($from_dt);
198 $debug && warn "SQL for start date ($field): $from_sql";
199 if ( $suggestion->{$from} || $suggestion->{$to} ) {
200 push @query, qq{ AND suggestions.$field BETWEEN ? AND ? };
201 push @sql_params, $from_sql;
202 push @sql_params,
203 output_pref({ dt => dt_from_string( $suggestion->{$to} ), dateformat => 'iso', dateonly => 1 }) || output_pref({ dt => dt_from_string, dateformat => 'iso', dateonly => 1 });
207 # By default do not search for archived suggestions
208 unless ( exists $suggestion->{archived} && $suggestion->{archived} ) {
209 push @query, q{ AND suggestions.archived = 0 };
212 $debug && warn "@query";
213 my $sth = $dbh->prepare("@query");
214 $sth->execute(@sql_params);
215 my @results;
217 # add status as field
218 while ( my $data = $sth->fetchrow_hashref ) {
219 $data->{ $data->{STATUS} } = 1;
220 push( @results, $data );
223 return ( \@results );
226 =head2 GetSuggestion
228 \%sth = &GetSuggestion($suggestionid)
230 this function get the detail of the suggestion $suggestionid (input arg)
232 return :
233 the result of the SQL query as a hash : $sth->fetchrow_hashref.
235 =cut
237 sub GetSuggestion {
238 my ($suggestionid) = @_;
239 my $dbh = C4::Context->dbh;
240 my $query = q{
241 SELECT *
242 FROM suggestions
243 WHERE suggestionid=?
245 my $sth = $dbh->prepare($query);
246 $sth->execute($suggestionid);
247 return ( $sth->fetchrow_hashref );
250 =head2 GetSuggestionFromBiblionumber
252 $ordernumber = &GetSuggestionFromBiblionumber($biblionumber)
254 Get a suggestion from it's biblionumber.
256 return :
257 the id of the suggestion which is related to the biblionumber given on input args.
259 =cut
261 sub GetSuggestionFromBiblionumber {
262 my ($biblionumber) = @_;
263 my $query = q{
264 SELECT suggestionid
265 FROM suggestions
266 WHERE biblionumber=? LIMIT 1
268 my $dbh = C4::Context->dbh;
269 my $sth = $dbh->prepare($query);
270 $sth->execute($biblionumber);
271 my ($suggestionid) = $sth->fetchrow;
272 return $suggestionid;
275 =head2 GetSuggestionInfoFromBiblionumber
277 Get a suggestion and borrower's informations from it's biblionumber.
279 return :
280 all informations (suggestion and borrower) of the suggestion which is related to the biblionumber given.
282 =cut
284 sub GetSuggestionInfoFromBiblionumber {
285 my ($biblionumber) = @_;
286 my $query = q{
287 SELECT suggestions.*,
288 U1.surname AS surnamesuggestedby,
289 U1.firstname AS firstnamesuggestedby,
290 U1.borrowernumber AS borrnumsuggestedby
291 FROM suggestions
292 LEFT JOIN borrowers AS U1 ON suggestedby=U1.borrowernumber
293 WHERE biblionumber=?
294 LIMIT 1
296 my $dbh = C4::Context->dbh;
297 my $sth = $dbh->prepare($query);
298 $sth->execute($biblionumber);
299 return $sth->fetchrow_hashref;
302 =head2 GetSuggestionInfo
304 Get a suggestion and borrower's informations from it's suggestionid
306 return :
307 all informations (suggestion and borrower) of the suggestion which is related to the suggestionid given.
309 =cut
311 sub GetSuggestionInfo {
312 my ($suggestionid) = @_;
313 my $query = q{
314 SELECT suggestions.*,
315 U1.surname AS surnamesuggestedby,
316 U1.firstname AS firstnamesuggestedby,
317 U1.borrowernumber AS borrnumsuggestedby
318 FROM suggestions
319 LEFT JOIN borrowers AS U1 ON suggestedby=U1.borrowernumber
320 WHERE suggestionid=?
321 LIMIT 1
323 my $dbh = C4::Context->dbh;
324 my $sth = $dbh->prepare($query);
325 $sth->execute($suggestionid);
326 return $sth->fetchrow_hashref;
329 =head2 GetSuggestionByStatus
331 $aqorders = &GetSuggestionByStatus($status,[$branchcode])
333 Get a suggestion from it's status
335 return :
336 all the suggestion with C<$status>
338 =cut
340 sub GetSuggestionByStatus {
341 my $status = shift;
342 my $branchcode = shift;
343 my $dbh = C4::Context->dbh;
344 my @sql_params = ($status);
345 my $query = q{
346 SELECT suggestions.*,
347 U1.surname AS surnamesuggestedby,
348 U1.firstname AS firstnamesuggestedby,
349 U1.branchcode AS branchcodesuggestedby,
350 B1.branchname AS branchnamesuggestedby,
351 U1.borrowernumber AS borrnumsuggestedby,
352 U1.categorycode AS categorycodesuggestedby,
353 C1.description AS categorydescriptionsuggestedby,
354 U2.surname AS surnamemanagedby,
355 U2.firstname AS firstnamemanagedby,
356 U2.borrowernumber AS borrnummanagedby
357 FROM suggestions
358 LEFT JOIN borrowers AS U1 ON suggestedby=U1.borrowernumber
359 LEFT JOIN borrowers AS U2 ON managedby=U2.borrowernumber
360 LEFT JOIN categories AS C1 ON C1.categorycode=U1.categorycode
361 LEFT JOIN branches AS B1 on B1.branchcode=U1.branchcode
362 WHERE status = ?
363 ORDER BY suggestionid
366 # filter on branch
367 if ( C4::Context->preference("IndependentBranches") || $branchcode ) {
368 my $userenv = C4::Context->userenv;
369 if ($userenv) {
370 unless ( C4::Context->IsSuperLibrarian() ) {
371 push @sql_params, $userenv->{branch};
372 $query .= q{ AND (U1.branchcode = ? OR U1.branchcode ='') };
375 if ($branchcode) {
376 push @sql_params, $branchcode;
377 $query .= q{ AND (U1.branchcode = ? OR U1.branchcode ='') };
381 my $sth = $dbh->prepare($query);
382 $sth->execute(@sql_params);
383 my $results;
384 $results = $sth->fetchall_arrayref( {} );
385 return $results;
388 =head2 NewSuggestion
391 &NewSuggestion($suggestion);
393 Insert a new suggestion on database with value given on input arg.
395 =cut
397 sub NewSuggestion {
398 my ($suggestion) = @_;
400 $suggestion->{STATUS} = "ASKED" unless $suggestion->{STATUS};
402 $suggestion->{suggesteddate} = dt_from_string unless $suggestion->{suggesteddate};
404 delete $suggestion->{branchcode} if $suggestion->{branchcode} eq '';
406 my $suggestion_object = Koha::Suggestion->new( $suggestion )->store;
407 my $suggestion_id = $suggestion_object->suggestionid;
409 my $emailpurchasesuggestions = C4::Context->preference("EmailPurchaseSuggestions");
410 if ($emailpurchasesuggestions) {
411 my $full_suggestion = GetSuggestion( $suggestion_id); # We should not need to refetch it!
412 if (
413 my $letter = C4::Letters::GetPreparedLetter(
414 module => 'suggestions',
415 letter_code => 'NEW_SUGGESTION',
416 tables => {
417 'branches' => $full_suggestion->{branchcode},
418 'borrowers' => $full_suggestion->{suggestedby},
419 'suggestions' => $full_suggestion,
424 my $toaddress;
425 if ( $emailpurchasesuggestions eq "BranchEmailAddress" ) {
426 my $library =
427 Koha::Libraries->find( $full_suggestion->{branchcode} );
428 $toaddress = $library->inbound_email_address;
430 elsif ( $emailpurchasesuggestions eq "KohaAdminEmailAddress" ) {
431 $toaddress = C4::Context->preference('ReplytoDefault')
432 || C4::Context->preference('KohaAdminEmailAddress');
434 else {
435 $toaddress =
436 C4::Context->preference($emailpurchasesuggestions)
437 || C4::Context->preference('ReplytoDefault')
438 || C4::Context->preference('KohaAdminEmailAddress');
441 C4::Letters::EnqueueLetter(
443 letter => $letter,
444 borrowernumber => $full_suggestion->{suggestedby},
445 suggestionid => $full_suggestion->{suggestionid},
446 to_address => $toaddress,
447 message_transport_type => 'email',
449 ) or warn "can't enqueue letter $letter";
453 return $suggestion_id;
456 =head2 ModSuggestion
458 &ModSuggestion($suggestion)
460 Modify the suggestion according to the hash passed by ref.
461 The hash HAS to contain suggestionid
462 Data not defined is not updated unless it is a note or sort1
463 Send a mail to notify the user that did the suggestion.
465 Note that there is no function to modify a suggestion.
467 =cut
469 sub ModSuggestion {
470 my ($suggestion) = @_;
471 return unless( $suggestion and defined($suggestion->{suggestionid}) );
473 my $suggestion_object = Koha::Suggestions->find( $suggestion->{suggestionid} );
474 eval { # FIXME Must raise an exception instead
475 $suggestion_object->set($suggestion)->store;
477 return 0 if $@;
479 if ( $suggestion->{STATUS} && $suggestion_object->suggestedby ) {
481 # fetch the entire updated suggestion so that we can populate the letter
482 my $full_suggestion = GetSuggestion( $suggestion->{suggestionid} );
484 my $patron = Koha::Patrons->find( $full_suggestion->{suggestedby} );
486 my $transport = (C4::Context->preference("FallbackToSMSIfNoEmail")) && ($patron->smsalertnumber) && (!$patron->email) ? 'sms' : 'email';
488 if (
489 my $letter = C4::Letters::GetPreparedLetter(
490 module => 'suggestions',
491 letter_code => $full_suggestion->{STATUS},
492 branchcode => $full_suggestion->{branchcode},
493 lang => $patron->lang,
494 tables => {
495 'branches' => $full_suggestion->{branchcode},
496 'borrowers' => $full_suggestion->{suggestedby},
497 'suggestions' => $full_suggestion,
498 'biblio' => $full_suggestion->{biblionumber},
503 C4::Letters::EnqueueLetter(
505 letter => $letter,
506 borrowernumber => $full_suggestion->{suggestedby},
507 suggestionid => $full_suggestion->{suggestionid},
508 LibraryName => C4::Context->preference("LibraryName"),
509 message_transport_type => $transport,
511 ) or warn "can't enqueue letter $letter";
514 return 1; # No useful if the exception is raised earlier
517 =head2 ConnectSuggestionAndBiblio
519 &ConnectSuggestionAndBiblio($ordernumber,$biblionumber)
521 connect a suggestion to an existing biblio
523 =cut
525 sub ConnectSuggestionAndBiblio {
526 my ( $suggestionid, $biblionumber ) = @_;
527 my $dbh = C4::Context->dbh;
528 my $query = q{
529 UPDATE suggestions
530 SET biblionumber=?
531 WHERE suggestionid=?
533 my $sth = $dbh->prepare($query);
534 $sth->execute( $biblionumber, $suggestionid );
537 =head2 DelSuggestion
539 &DelSuggestion($borrowernumber,$ordernumber)
541 Delete a suggestion. A borrower can delete a suggestion only if they are its owner.
543 =cut
545 sub DelSuggestion {
546 my ( $borrowernumber, $suggestionid, $type ) = @_;
547 my $dbh = C4::Context->dbh;
549 # check that the suggestion comes from the suggestor
550 my $query = q{
551 SELECT suggestedby
552 FROM suggestions
553 WHERE suggestionid=?
555 my $sth = $dbh->prepare($query);
556 $sth->execute($suggestionid);
557 my ($suggestedby) = $sth->fetchrow;
558 if ( $type eq 'intranet' || $suggestedby eq $borrowernumber ) {
559 my $queryDelete = q{
560 DELETE FROM suggestions
561 WHERE suggestionid=?
563 $sth = $dbh->prepare($queryDelete);
564 my $suggestiondeleted = $sth->execute($suggestionid);
565 return $suggestiondeleted;
569 =head2 DelSuggestionsOlderThan
570 &DelSuggestionsOlderThan($days)
572 Delete all suggestions older than TODAY-$days , that have be accepted or rejected.
573 We do now allow a negative number. If you want to delete all suggestions, just use Koha::Suggestions->delete or so.
575 =cut
577 sub DelSuggestionsOlderThan {
578 my ($days) = @_;
579 return unless $days && $days > 0;
580 my $dbh = C4::Context->dbh;
581 my $sth = $dbh->prepare(
583 DELETE FROM suggestions
584 WHERE STATUS<>'ASKED'
585 AND date < ADDDATE(NOW(), ?)
588 $sth->execute("-$days");
591 sub GetUnprocessedSuggestions {
592 my ( $number_of_days_since_the_last_modification ) = @_;
594 $number_of_days_since_the_last_modification ||= 0;
596 my $dbh = C4::Context->dbh;
598 my $s = $dbh->selectall_arrayref(q|
599 SELECT *
600 FROM suggestions
601 WHERE STATUS = 'ASKED'
602 AND budgetid IS NOT NULL
603 AND CAST(NOW() AS DATE) - INTERVAL ? DAY = CAST(suggesteddate AS DATE)
604 |, { Slice => {} }, $number_of_days_since_the_last_modification );
605 return $s;
608 =head2 MarcRecordFromNewSuggestion
610 $record = MarcRecordFromNewSuggestion ( $suggestion )
612 This function build a marc record object from a suggestion
614 =cut
616 sub MarcRecordFromNewSuggestion {
617 my ($suggestion) = @_;
618 my $record = MARC::Record->new();
620 my ($title_tag, $title_subfield) = GetMarcFromKohaField('biblio.title', '');
621 $record->append_fields(
622 MARC::Field->new($title_tag, ' ', ' ', $title_subfield => $suggestion->{title})
625 my ($author_tag, $author_subfield) = GetMarcFromKohaField('biblio.author', '');
626 if ($record->field( $author_tag )) {
627 $record->field( $author_tag )->add_subfields( $author_subfield => $suggestion->{author} );
629 else {
630 $record->append_fields(
631 MARC::Field->new($author_tag, ' ', ' ', $author_subfield => $suggestion->{author})
635 my ($it_tag, $it_subfield) = GetMarcFromKohaField('biblioitems.itemtype', '');
636 if ($record->field( $it_tag )) {
637 $record->field( $it_tag )->add_subfields( $it_subfield => $suggestion->{itemtype} );
639 else {
640 $record->append_fields(
641 MARC::Field->new($it_tag, ' ', ' ', $it_subfield => $suggestion->{itemtype})
645 return $record;
649 __END__
652 =head1 AUTHOR
654 Koha Development Team <http://koha-community.org/>
656 =cut