Bug 13937: (follow-up) Correct error call to use self
[koha.git] / C4 / Letters.pm
blobbdb213a49e81962cce87c0f8ae67581e19f8ad34
1 package C4::Letters;
3 # Copyright 2000-2002 Katipo Communications
5 # This file is part of Koha.
7 # Koha is free software; you can redistribute it and/or modify it
8 # under the terms of the GNU General Public License as published by
9 # the Free Software Foundation; either version 3 of the License, or
10 # (at your option) any later version.
12 # Koha is distributed in the hope that it will be useful, but
13 # WITHOUT ANY WARRANTY; without even the implied warranty of
14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 # GNU General Public License for more details.
17 # You should have received a copy of the GNU General Public License
18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
20 use Modern::Perl;
22 use MIME::Lite;
23 use Mail::Sendmail;
24 use Date::Calc qw( Add_Delta_Days );
25 use Encode;
26 use Carp;
27 use Template;
28 use Module::Load::Conditional qw(can_load);
30 use C4::Members;
31 use C4::Members::Attributes qw(GetBorrowerAttributes);
32 use C4::Log;
33 use C4::SMS;
34 use C4::Debug;
35 use Koha::DateUtils;
36 use Koha::SMS::Providers;
38 use Koha::Email;
39 use Koha::Notice::Messages;
40 use Koha::DateUtils qw( format_sqldatetime dt_from_string );
41 use Koha::Patrons;
42 use Koha::Subscriptions;
44 use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
46 BEGIN {
47 require Exporter;
48 @ISA = qw(Exporter);
49 @EXPORT = qw(
50 &GetLetters &GetLettersAvailableForALibrary &GetLetterTemplates &DelLetter &GetPreparedLetter &GetWrappedLetter &SendAlerts &GetPrintMessages &GetMessageTransportTypes
54 =head1 NAME
56 C4::Letters - Give functions for Letters management
58 =head1 SYNOPSIS
60 use C4::Letters;
62 =head1 DESCRIPTION
64 "Letters" is the tool used in Koha to manage informations sent to the patrons and/or the library. This include some cron jobs like
65 late issues, as well as other tasks like sending a mail to users that have subscribed to a "serial issue alert" (= being warned every time a new issue has arrived at the library)
67 Letters are managed through "alerts" sent by Koha on some events. All "alert" related functions are in this module too.
69 =head2 GetLetters([$module])
71 $letters = &GetLetters($module);
72 returns informations about letters.
73 if needed, $module filters for letters given module
75 DEPRECATED - You must use Koha::Notice::Templates instead
76 The group by clause is confusing and can lead to issues
78 =cut
80 sub GetLetters {
81 my ($filters) = @_;
82 my $module = $filters->{module};
83 my $code = $filters->{code};
84 my $branchcode = $filters->{branchcode};
85 my $dbh = C4::Context->dbh;
86 my $letters = $dbh->selectall_arrayref(
88 SELECT code, module, name
89 FROM letter
90 WHERE 1
92 . ( $module ? q| AND module = ?| : q|| )
93 . ( $code ? q| AND code = ?| : q|| )
94 . ( defined $branchcode ? q| AND branchcode = ?| : q|| )
95 . q| GROUP BY code, module, name ORDER BY name|, { Slice => {} }
96 , ( $module ? $module : () )
97 , ( $code ? $code : () )
98 , ( defined $branchcode ? $branchcode : () )
101 return $letters;
104 =head2 GetLetterTemplates
106 my $letter_templates = GetLetterTemplates(
108 module => 'circulation',
109 code => 'my code',
110 branchcode => 'CPL', # '' for default,
114 Return a hashref of letter templates.
116 =cut
118 sub GetLetterTemplates {
119 my ( $params ) = @_;
121 my $module = $params->{module};
122 my $code = $params->{code};
123 my $branchcode = $params->{branchcode} // '';
124 my $dbh = C4::Context->dbh;
125 my $letters = $dbh->selectall_arrayref(
127 SELECT module, code, branchcode, name, is_html, title, content, message_transport_type, lang
128 FROM letter
129 WHERE module = ?
130 AND code = ?
131 and branchcode = ?
133 , { Slice => {} }
134 , $module, $code, $branchcode
137 return $letters;
140 =head2 GetLettersAvailableForALibrary
142 my $letters = GetLettersAvailableForALibrary(
144 branchcode => 'CPL', # '' for default
145 module => 'circulation',
149 Return an arrayref of letters, sorted by name.
150 If a specific letter exist for the given branchcode, it will be retrieve.
151 Otherwise the default letter will be.
153 =cut
155 sub GetLettersAvailableForALibrary {
156 my ($filters) = @_;
157 my $branchcode = $filters->{branchcode};
158 my $module = $filters->{module};
160 croak "module should be provided" unless $module;
162 my $dbh = C4::Context->dbh;
163 my $default_letters = $dbh->selectall_arrayref(
165 SELECT module, code, branchcode, name
166 FROM letter
167 WHERE 1
169 . q| AND branchcode = ''|
170 . ( $module ? q| AND module = ?| : q|| )
171 . q| ORDER BY name|, { Slice => {} }
172 , ( $module ? $module : () )
175 my $specific_letters;
176 if ($branchcode) {
177 $specific_letters = $dbh->selectall_arrayref(
179 SELECT module, code, branchcode, name
180 FROM letter
181 WHERE 1
183 . q| AND branchcode = ?|
184 . ( $module ? q| AND module = ?| : q|| )
185 . q| ORDER BY name|, { Slice => {} }
186 , $branchcode
187 , ( $module ? $module : () )
191 my %letters;
192 for my $l (@$default_letters) {
193 $letters{ $l->{code} } = $l;
195 for my $l (@$specific_letters) {
196 # Overwrite the default letter with the specific one.
197 $letters{ $l->{code} } = $l;
200 return [ map { $letters{$_} }
201 sort { $letters{$a}->{name} cmp $letters{$b}->{name} }
202 keys %letters ];
206 sub getletter {
207 my ( $module, $code, $branchcode, $message_transport_type, $lang) = @_;
208 $message_transport_type //= '%';
209 $lang = 'default' unless( $lang && C4::Context->preference('TranslateNotices') );
212 my $only_my_library = C4::Context->only_my_library;
213 if ( $only_my_library and $branchcode ) {
214 $branchcode = C4::Context::mybranch();
216 $branchcode //= '';
218 my $dbh = C4::Context->dbh;
219 my $sth = $dbh->prepare(q{
220 SELECT *
221 FROM letter
222 WHERE module=? AND code=? AND (branchcode = ? OR branchcode = '')
223 AND message_transport_type LIKE ?
224 AND lang =?
225 ORDER BY branchcode DESC LIMIT 1
227 $sth->execute( $module, $code, $branchcode, $message_transport_type, $lang );
228 my $line = $sth->fetchrow_hashref
229 or return;
230 $line->{'content-type'} = 'text/html; charset="UTF-8"' if $line->{is_html};
231 return { %$line };
235 =head2 DelLetter
237 DelLetter(
239 branchcode => 'CPL',
240 module => 'circulation',
241 code => 'my code',
242 [ mtt => 'email', ]
246 Delete the letter. The mtt parameter is facultative.
247 If not given, all templates mathing the other parameters will be removed.
249 =cut
251 sub DelLetter {
252 my ($params) = @_;
253 my $branchcode = $params->{branchcode};
254 my $module = $params->{module};
255 my $code = $params->{code};
256 my $mtt = $params->{mtt};
257 my $lang = $params->{lang};
258 my $dbh = C4::Context->dbh;
259 $dbh->do(q|
260 DELETE FROM letter
261 WHERE branchcode = ?
262 AND module = ?
263 AND code = ?
265 . ( $mtt ? q| AND message_transport_type = ?| : q|| )
266 . ( $lang? q| AND lang = ?| : q|| )
267 , undef, $branchcode, $module, $code, ( $mtt ? $mtt : () ), ( $lang ? $lang : () ) );
270 =head2 SendAlerts
272 my $err = &SendAlerts($type, $externalid, $letter_code);
274 Parameters:
275 - $type : the type of alert
276 - $externalid : the id of the "object" to query
277 - $letter_code : the notice template to use
279 C<&SendAlerts> sends an email notice directly to a patron or a vendor.
281 Currently it supports ($type):
282 - claim serial issues (claimissues)
283 - claim acquisition orders (claimacquisition)
284 - send acquisition orders to the vendor (orderacquisition)
285 - notify patrons about newly received serial issues (issue)
286 - notify patrons when their account is created (members)
288 Returns undef or { error => 'message } on failure.
289 Returns true on success.
291 =cut
293 sub SendAlerts {
294 my ( $type, $externalid, $letter_code ) = @_;
295 my $dbh = C4::Context->dbh;
296 if ( $type eq 'issue' ) {
298 # prepare the letter...
299 # search the subscriptionid
300 my $sth =
301 $dbh->prepare(
302 "SELECT subscriptionid FROM serial WHERE serialid=?");
303 $sth->execute($externalid);
304 my ($subscriptionid) = $sth->fetchrow
305 or warn( "No subscription for '$externalid'" ),
306 return;
308 # search the biblionumber
309 $sth =
310 $dbh->prepare(
311 "SELECT biblionumber FROM subscription WHERE subscriptionid=?");
312 $sth->execute($subscriptionid);
313 my ($biblionumber) = $sth->fetchrow
314 or warn( "No biblionumber for '$subscriptionid'" ),
315 return;
317 my %letter;
318 # find the list of subscribers to notify
319 my $subscription = Koha::Subscriptions->find( $subscriptionid );
320 my $subscribers = $subscription->subscribers;
321 while ( my $patron = $subscribers->next ) {
322 my $email = $patron->email or next;
324 # warn "sending issues...";
325 my $userenv = C4::Context->userenv;
326 my $library = $patron->library;
327 my $letter = GetPreparedLetter (
328 module => 'serial',
329 letter_code => $letter_code,
330 branchcode => $userenv->{branch},
331 tables => {
332 'branches' => $library->branchcode,
333 'biblio' => $biblionumber,
334 'biblioitems' => $biblionumber,
335 'borrowers' => $patron->unblessed,
336 'subscription' => $subscriptionid,
337 'serial' => $externalid,
339 want_librarian => 1,
340 ) or return;
342 # ... then send mail
343 my $message = Koha::Email->new();
344 my %mail = $message->create_message_headers(
346 to => $email,
347 from => $library->branchemail,
348 replyto => $library->branchreplyto,
349 sender => $library->branchreturnpath,
350 subject => Encode::encode( "UTF-8", "" . $letter->{title} ),
351 message => $letter->{'is_html'}
352 ? _wrap_html( Encode::encode( "UTF-8", $letter->{'content'} ),
353 Encode::encode( "UTF-8", "" . $letter->{'title'} ))
354 : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
355 contenttype => $letter->{'is_html'}
356 ? 'text/html; charset="utf-8"'
357 : 'text/plain; charset="utf-8"',
360 unless( Mail::Sendmail::sendmail(%mail) ) {
361 carp $Mail::Sendmail::error;
362 return { error => $Mail::Sendmail::error };
366 elsif ( $type eq 'claimacquisition' or $type eq 'claimissues' or $type eq 'orderacquisition' ) {
368 # prepare the letter...
369 my $strsth;
370 my $sthorders;
371 my $dataorders;
372 my $action;
373 if ( $type eq 'claimacquisition') {
374 $strsth = qq{
375 SELECT aqorders.*,aqbasket.*,biblio.*,biblioitems.*
376 FROM aqorders
377 LEFT JOIN aqbasket ON aqbasket.basketno=aqorders.basketno
378 LEFT JOIN biblio ON aqorders.biblionumber=biblio.biblionumber
379 LEFT JOIN biblioitems ON aqorders.biblionumber=biblioitems.biblionumber
380 WHERE aqorders.ordernumber IN (
383 if (!@$externalid){
384 carp "No order selected";
385 return { error => "no_order_selected" };
387 $strsth .= join( ",", ('?') x @$externalid ) . ")";
388 $action = "ACQUISITION CLAIM";
389 $sthorders = $dbh->prepare($strsth);
390 $sthorders->execute( @$externalid );
391 $dataorders = $sthorders->fetchall_arrayref( {} );
394 if ($type eq 'claimissues') {
395 $strsth = qq{
396 SELECT serial.*,subscription.*, biblio.*, biblioitems.*, aqbooksellers.*,
397 aqbooksellers.id AS booksellerid
398 FROM serial
399 LEFT JOIN subscription ON serial.subscriptionid=subscription.subscriptionid
400 LEFT JOIN biblio ON serial.biblionumber=biblio.biblionumber
401 LEFT JOIN biblioitems ON serial.biblionumber = biblioitems.biblionumber
402 LEFT JOIN aqbooksellers ON subscription.aqbooksellerid=aqbooksellers.id
403 WHERE serial.serialid IN (
406 if (!@$externalid){
407 carp "No issues selected";
408 return { error => "no_issues_selected" };
411 $strsth .= join( ",", ('?') x @$externalid ) . ")";
412 $action = "SERIAL CLAIM";
413 $sthorders = $dbh->prepare($strsth);
414 $sthorders->execute( @$externalid );
415 $dataorders = $sthorders->fetchall_arrayref( {} );
418 if ( $type eq 'orderacquisition') {
419 $strsth = qq{
420 SELECT aqorders.*,aqbasket.*,biblio.*,biblioitems.*
421 FROM aqorders
422 LEFT JOIN aqbasket ON aqbasket.basketno=aqorders.basketno
423 LEFT JOIN biblio ON aqorders.biblionumber=biblio.biblionumber
424 LEFT JOIN biblioitems ON aqorders.biblionumber=biblioitems.biblionumber
425 WHERE aqbasket.basketno = ?
426 AND orderstatus IN ('new','ordered')
429 if (!$externalid){
430 carp "No basketnumber given";
431 return { error => "no_basketno" };
433 $action = "ACQUISITION ORDER";
434 $sthorders = $dbh->prepare($strsth);
435 $sthorders->execute($externalid);
436 $dataorders = $sthorders->fetchall_arrayref( {} );
439 my $sthbookseller =
440 $dbh->prepare("select * from aqbooksellers where id=?");
441 $sthbookseller->execute( $dataorders->[0]->{booksellerid} );
442 my $databookseller = $sthbookseller->fetchrow_hashref;
444 my $addressee = $type eq 'claimacquisition' || $type eq 'orderacquisition' ? 'acqprimary' : 'serialsprimary';
446 my $sthcontact =
447 $dbh->prepare("SELECT * FROM aqcontacts WHERE booksellerid=? AND $type=1 ORDER BY $addressee DESC");
448 $sthcontact->execute( $dataorders->[0]->{booksellerid} );
449 my $datacontact = $sthcontact->fetchrow_hashref;
451 my @email;
452 my @cc;
453 push @email, $databookseller->{bookselleremail} if $databookseller->{bookselleremail};
454 push @email, $datacontact->{email} if ( $datacontact && $datacontact->{email} );
455 unless (@email) {
456 warn "Bookseller $dataorders->[0]->{booksellerid} without emails";
457 return { error => "no_email" };
459 my $addlcontact;
460 while ($addlcontact = $sthcontact->fetchrow_hashref) {
461 push @cc, $addlcontact->{email} if ( $addlcontact && $addlcontact->{email} );
464 my $userenv = C4::Context->userenv;
465 my $letter = GetPreparedLetter (
466 module => $type,
467 letter_code => $letter_code,
468 branchcode => $userenv->{branch},
469 tables => {
470 'branches' => $userenv->{branch},
471 'aqbooksellers' => $databookseller,
472 'aqcontacts' => $datacontact,
474 repeat => $dataorders,
475 want_librarian => 1,
476 ) or return { error => "no_letter" };
478 # Remove the order tag
479 $letter->{content} =~ s/<order>(.*?)<\/order>/$1/gxms;
481 # ... then send mail
482 my $library = Koha::Libraries->find( $userenv->{branch} );
483 my $email = Koha::Email->new();
484 my %mail = $email->create_message_headers(
486 to => join( ',', @email ),
487 cc => join( ',', @cc ),
490 C4::Context->preference("ClaimsBccCopy")
491 && ( $type eq 'claimacquisition'
492 || $type eq 'claimissues' )
493 ) ? ( bcc => $userenv->{emailaddress} )
494 : ()
496 from => $library->branchemail
497 || C4::Context->preference('KohaAdminEmailAddress'),
498 subject => Encode::encode( "UTF-8", "" . $letter->{title} ),
499 message => $letter->{'is_html'} ? _wrap_html(
500 Encode::encode( "UTF-8", $letter->{'content'} ),
501 Encode::encode( "UTF-8", "" . $letter->{'title'} )
503 : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
504 contenttype => $letter->{'is_html'}
505 ? 'text/html; charset="utf-8"'
506 : 'text/plain; charset="utf-8"',
510 unless ( Mail::Sendmail::sendmail(%mail) ) {
511 carp $Mail::Sendmail::error;
512 return { error => $Mail::Sendmail::error };
515 logaction(
516 "ACQUISITION",
517 $action,
518 undef,
519 "To="
520 . join( ',', @email )
521 . " Title="
522 . $letter->{title}
523 . " Content="
524 . $letter->{content}
525 ) if C4::Context->preference("LetterLog");
527 # send an "account details" notice to a newly created user
528 elsif ( $type eq 'members' ) {
529 my $library = Koha::Libraries->find( $externalid->{branchcode} )->unblessed;
530 my $letter = GetPreparedLetter (
531 module => 'members',
532 letter_code => $letter_code,
533 branchcode => $externalid->{'branchcode'},
534 lang => $externalid->{lang} || 'default',
535 tables => {
536 'branches' => $library,
537 'borrowers' => $externalid->{'borrowernumber'},
539 substitute => { 'borrowers.password' => $externalid->{'password'} },
540 want_librarian => 1,
541 ) or return;
542 return { error => "no_email" } unless $externalid->{'emailaddr'};
543 my $email = Koha::Email->new();
544 my %mail = $email->create_message_headers(
546 to => $externalid->{'emailaddr'},
547 from => $library->{branchemail},
548 replyto => $library->{branchreplyto},
549 sender => $library->{branchreturnpath},
550 subject => Encode::encode( "UTF-8", "" . $letter->{'title'} ),
551 message => $letter->{'is_html'}
552 ? _wrap_html( Encode::encode( "UTF-8", $letter->{'content'} ),
553 Encode::encode( "UTF-8", "" . $letter->{'title'} ) )
554 : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
555 contenttype => $letter->{'is_html'}
556 ? 'text/html; charset="utf-8"'
557 : 'text/plain; charset="utf-8"',
560 unless( Mail::Sendmail::sendmail(%mail) ) {
561 carp $Mail::Sendmail::error;
562 return { error => $Mail::Sendmail::error };
566 # If we come here, return an OK status
567 return 1;
570 =head2 GetPreparedLetter( %params )
572 %params hash:
573 module => letter module, mandatory
574 letter_code => letter code, mandatory
575 branchcode => for letter selection, if missing default system letter taken
576 tables => a hashref with table names as keys. Values are either:
577 - a scalar - primary key value
578 - an arrayref - primary key values
579 - a hashref - full record
580 substitute => custom substitution key/value pairs
581 repeat => records to be substituted on consecutive lines:
582 - an arrayref - tries to guess what needs substituting by
583 taking remaining << >> tokensr; not recommended
584 - a hashref token => @tables - replaces <token> << >> << >> </token>
585 subtemplate for each @tables row; table is a hashref as above
586 want_librarian => boolean, if set to true triggers librarian details
587 substitution from the userenv
588 Return value:
589 letter fields hashref (title & content useful)
591 =cut
593 sub GetPreparedLetter {
594 my %params = @_;
596 my $letter = $params{letter};
598 unless ( $letter ) {
599 my $module = $params{module} or croak "No module";
600 my $letter_code = $params{letter_code} or croak "No letter_code";
601 my $branchcode = $params{branchcode} || '';
602 my $mtt = $params{message_transport_type} || 'email';
603 my $lang = $params{lang} || 'default';
605 $letter = getletter( $module, $letter_code, $branchcode, $mtt, $lang );
607 unless ( $letter ) {
608 $letter = getletter( $module, $letter_code, $branchcode, $mtt, 'default' )
609 or warn( "No $module $letter_code letter transported by " . $mtt ),
610 return;
614 my $tables = $params{tables} || {};
615 my $substitute = $params{substitute} || {};
616 my $loops = $params{loops} || {}; # loops is not supported for historical notices syntax
617 my $repeat = $params{repeat};
618 %$tables || %$substitute || $repeat || %$loops
619 or carp( "ERROR: nothing to substitute - both 'tables', 'loops' and 'substitute' are empty" ),
620 return;
621 my $want_librarian = $params{want_librarian};
623 if (%$substitute) {
624 while ( my ($token, $val) = each %$substitute ) {
625 if ( $token eq 'items.content' ) {
626 $val =~ s|\n|<br/>|g if $letter->{is_html};
629 $letter->{title} =~ s/<<$token>>/$val/g;
630 $letter->{content} =~ s/<<$token>>/$val/g;
634 my $OPACBaseURL = C4::Context->preference('OPACBaseURL');
635 $letter->{content} =~ s/<<OPACBaseURL>>/$OPACBaseURL/go;
637 if ($want_librarian) {
638 # parsing librarian name
639 my $userenv = C4::Context->userenv;
640 $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/go;
641 $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/go;
642 $letter->{content} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/go;
645 my ($repeat_no_enclosing_tags, $repeat_enclosing_tags);
647 if ($repeat) {
648 if (ref ($repeat) eq 'ARRAY' ) {
649 $repeat_no_enclosing_tags = $repeat;
650 } else {
651 $repeat_enclosing_tags = $repeat;
655 if ($repeat_enclosing_tags) {
656 while ( my ($tag, $tag_tables) = each %$repeat_enclosing_tags ) {
657 if ( $letter->{content} =~ m!<$tag>(.*)</$tag>!s ) {
658 my $subcontent = $1;
659 my @lines = map {
660 my %subletter = ( title => '', content => $subcontent );
661 _substitute_tables( \%subletter, $_ );
662 $subletter{content};
663 } @$tag_tables;
664 $letter->{content} =~ s!<$tag>.*</$tag>!join( "\n", @lines )!se;
669 if (%$tables) {
670 _substitute_tables( $letter, $tables );
673 if ($repeat_no_enclosing_tags) {
674 if ( $letter->{content} =~ m/[^\n]*<<.*>>[^\n]*/so ) {
675 my $line = $&;
676 my $i = 1;
677 my @lines = map {
678 my $c = $line;
679 $c =~ s/<<count>>/$i/go;
680 foreach my $field ( keys %{$_} ) {
681 $c =~ s/(<<[^\.]+.$field>>)/$_->{$field}/;
683 $i++;
685 } @$repeat_no_enclosing_tags;
687 my $replaceby = join( "\n", @lines );
688 $letter->{content} =~ s/\Q$line\E/$replaceby/s;
692 $letter->{content} = _process_tt(
694 content => $letter->{content},
695 tables => $tables,
696 loops => $loops,
697 substitute => $substitute,
701 $letter->{content} =~ s/<<\S*>>//go; #remove any stragglers
703 return $letter;
706 sub _substitute_tables {
707 my ( $letter, $tables ) = @_;
708 while ( my ($table, $param) = each %$tables ) {
709 next unless $param;
711 my $ref = ref $param;
713 my $values;
714 if ($ref && $ref eq 'HASH') {
715 $values = $param;
717 else {
718 my $sth = _parseletter_sth($table);
719 unless ($sth) {
720 warn "_parseletter_sth('$table') failed to return a valid sth. No substitution will be done for that table.";
721 return;
723 $sth->execute( $ref ? @$param : $param );
725 $values = $sth->fetchrow_hashref;
726 $sth->finish();
729 _parseletter ( $letter, $table, $values );
733 sub _parseletter_sth {
734 my $table = shift;
735 my $sth;
736 unless ($table) {
737 carp "ERROR: _parseletter_sth() called without argument (table)";
738 return;
740 # NOTE: we used to check whether we had a statement handle cached in
741 # a %handles module-level variable. This was a dumb move and
742 # broke things for the rest of us. prepare_cached is a better
743 # way to cache statement handles anyway.
744 my $query =
745 ($table eq 'biblio' ) ? "SELECT * FROM $table WHERE biblionumber = ?" :
746 ($table eq 'biblioitems' ) ? "SELECT * FROM $table WHERE biblionumber = ?" :
747 ($table eq 'items' ) ? "SELECT * FROM $table WHERE itemnumber = ?" :
748 ($table eq 'issues' ) ? "SELECT * FROM $table WHERE itemnumber = ?" :
749 ($table eq 'old_issues' ) ? "SELECT * FROM $table WHERE itemnumber = ? ORDER BY timestamp DESC LIMIT 1" :
750 ($table eq 'reserves' ) ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?" :
751 ($table eq 'borrowers' ) ? "SELECT * FROM $table WHERE borrowernumber = ?" :
752 ($table eq 'branches' ) ? "SELECT * FROM $table WHERE branchcode = ?" :
753 ($table eq 'suggestions' ) ? "SELECT * FROM $table WHERE suggestionid = ?" :
754 ($table eq 'aqbooksellers') ? "SELECT * FROM $table WHERE id = ?" :
755 ($table eq 'aqorders' ) ? "SELECT * FROM $table WHERE ordernumber = ?" :
756 ($table eq 'opac_news' ) ? "SELECT * FROM $table WHERE idnew = ?" :
757 ($table eq 'article_requests') ? "SELECT * FROM $table WHERE id = ?" :
758 ($table eq 'borrower_modifications') ? "SELECT * FROM $table WHERE verification_token = ?" :
759 ($table eq 'subscription') ? "SELECT * FROM $table WHERE subscriptionid = ?" :
760 ($table eq 'serial') ? "SELECT * FROM $table WHERE serialid = ?" :
761 undef ;
762 unless ($query) {
763 warn "ERROR: No _parseletter_sth query for table '$table'";
764 return; # nothing to get
766 unless ($sth = C4::Context->dbh->prepare_cached($query)) {
767 warn "ERROR: Failed to prepare query: '$query'";
768 return;
770 return $sth; # now cache is populated for that $table
773 =head2 _parseletter($letter, $table, $values)
775 parameters :
776 - $letter : a hash to letter fields (title & content useful)
777 - $table : the Koha table to parse.
778 - $values_in : table record hashref
779 parse all fields from a table, and replace values in title & content with the appropriate value
780 (not exported sub, used only internally)
782 =cut
784 sub _parseletter {
785 my ( $letter, $table, $values_in ) = @_;
787 # Work on a local copy of $values_in (passed by reference) to avoid side effects
788 # in callers ( by changing / formatting values )
789 my $values = $values_in ? { %$values_in } : {};
791 if ( $table eq 'borrowers' && $values->{'dateexpiry'} ){
792 $values->{'dateexpiry'} = output_pref({ dt => dt_from_string( $values->{'dateexpiry'} ), dateonly => 1 });
795 if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
796 $values->{'waitingdate'} = output_pref({ dt => dt_from_string( $values->{'waitingdate'} ), dateonly => 1 });
799 if ($letter->{content} && $letter->{content} =~ /<<today>>/) {
800 my $todaysdate = output_pref( DateTime->now() );
801 $letter->{content} =~ s/<<today>>/$todaysdate/go;
804 while ( my ($field, $val) = each %$values ) {
805 $val =~ s/\p{P}$// if $val && $table=~/biblio/;
806 #BZ 9886: Assuming that we want to eliminate ISBD punctuation here
807 #Therefore adding the test on biblio. This includes biblioitems,
808 #but excludes items. Removed unneeded global and lookahead.
810 if ( $table=~/^borrowers$/ && $field=~/^streettype$/ ) {
811 my $av = Koha::AuthorisedValues->search({ category => 'ROADTYPE', authorised_value => $val });
812 $val = $av->count ? $av->next->lib : '';
815 # Dates replacement
816 my $replacedby = defined ($val) ? $val : '';
817 if ( $replacedby
818 and not $replacedby =~ m|0000-00-00|
819 and not $replacedby =~ m|9999-12-31|
820 and $replacedby =~ m|^\d{4}-\d{2}-\d{2}( \d{2}:\d{2}:\d{2})?$| )
822 # If the value is XXXX-YY-ZZ[ AA:BB:CC] we assume it is a date
823 my $dateonly = defined $1 ? 0 : 1; #$1 refers to the capture group wrapped in parentheses. In this case, that's the hours, minutes, seconds.
824 my $re_dateonly_filter = qr{ $field( \s* \| \s* dateonly\s*)?>> }xms;
826 for my $letter_field ( qw( title content ) ) {
827 my $filter_string_used = q{};
828 if ( $letter->{ $letter_field } =~ $re_dateonly_filter ) {
829 # We overwrite $dateonly if the filter exists and we have a time in the datetime
830 $filter_string_used = $1 || q{};
831 $dateonly = $1 unless $dateonly;
833 my $replacedby_date = eval {
834 output_pref({ dt => dt_from_string( $replacedby ), dateonly => $dateonly });
837 if ( $letter->{ $letter_field } ) {
838 $letter->{ $letter_field } =~ s/\Q<<$table.$field$filter_string_used>>\E/$replacedby_date/g;
839 $letter->{ $letter_field } =~ s/\Q<<$field$filter_string_used>>\E/$replacedby_date/g;
843 # Other fields replacement
844 else {
845 for my $letter_field ( qw( title content ) ) {
846 if ( $letter->{ $letter_field } ) {
847 $letter->{ $letter_field } =~ s/<<$table.$field>>/$replacedby/g;
848 $letter->{ $letter_field } =~ s/<<$field>>/$replacedby/g;
854 if ($table eq 'borrowers' && $letter->{content}) {
855 if ( my $attributes = GetBorrowerAttributes($values->{borrowernumber}) ) {
856 my %attr;
857 foreach (@$attributes) {
858 my $code = $_->{code};
859 my $val = $_->{value_description} || $_->{value};
860 $val =~ s/\p{P}(?=$)//g if $val;
861 next unless $val gt '';
862 $attr{$code} ||= [];
863 push @{ $attr{$code} }, $val;
865 while ( my ($code, $val_ar) = each %attr ) {
866 my $replacefield = "<<borrower-attribute:$code>>";
867 my $replacedby = join ',', @$val_ar;
868 $letter->{content} =~ s/$replacefield/$replacedby/g;
872 return $letter;
875 =head2 EnqueueLetter
877 my $success = EnqueueLetter( { letter => $letter,
878 borrowernumber => '12', message_transport_type => 'email' } )
880 places a letter in the message_queue database table, which will
881 eventually get processed (sent) by the process_message_queue.pl
882 cronjob when it calls SendQueuedMessages.
884 return message_id on success
886 =cut
888 sub EnqueueLetter {
889 my $params = shift or return;
891 return unless exists $params->{'letter'};
892 # return unless exists $params->{'borrowernumber'};
893 return unless exists $params->{'message_transport_type'};
895 my $content = $params->{letter}->{content};
896 $content =~ s/\s+//g if(defined $content);
897 if ( not defined $content or $content eq '' ) {
898 warn "Trying to add an empty message to the message queue" if $debug;
899 return;
902 # If we have any attachments we should encode then into the body.
903 if ( $params->{'attachments'} ) {
904 $params->{'letter'} = _add_attachments(
905 { letter => $params->{'letter'},
906 attachments => $params->{'attachments'},
907 message => MIME::Lite->new( Type => 'multipart/mixed' ),
912 my $dbh = C4::Context->dbh();
913 my $statement = << 'ENDSQL';
914 INSERT INTO message_queue
915 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type )
916 VALUES
917 ( ?, ?, ?, ?, ?, ?, ?, NOW(), ?, ?, ? )
918 ENDSQL
920 my $sth = $dbh->prepare($statement);
921 my $result = $sth->execute(
922 $params->{'borrowernumber'}, # borrowernumber
923 $params->{'letter'}->{'title'}, # subject
924 $params->{'letter'}->{'content'}, # content
925 $params->{'letter'}->{'metadata'} || '', # metadata
926 $params->{'letter'}->{'code'} || '', # letter_code
927 $params->{'message_transport_type'}, # message_transport_type
928 'pending', # status
929 $params->{'to_address'}, # to_address
930 $params->{'from_address'}, # from_address
931 $params->{'letter'}->{'content-type'}, # content_type
933 return $dbh->last_insert_id(undef,undef,'message_queue', undef);
936 =head2 SendQueuedMessages ([$hashref])
938 my $sent = SendQueuedMessages({
939 letter_code => $letter_code,
940 borrowernumber => $who_letter_is_for,
941 limit => 50,
942 verbose => 1,
943 type => 'sms',
946 Sends all of the 'pending' items in the message queue, unless
947 parameters are passed.
949 The letter_code, borrowernumber and limit parameters are used
950 to build a parameter set for _get_unsent_messages, thus limiting
951 which pending messages will be processed. They are all optional.
953 The verbose parameter can be used to generate debugging output.
954 It is also optional.
956 Returns number of messages sent.
958 =cut
960 sub SendQueuedMessages {
961 my $params = shift;
963 my $which_unsent_messages = {
964 'limit' => $params->{'limit'} // 0,
965 'borrowernumber' => $params->{'borrowernumber'} // q{},
966 'letter_code' => $params->{'letter_code'} // q{},
967 'type' => $params->{'type'} // q{},
969 my $unsent_messages = _get_unsent_messages( $which_unsent_messages );
970 MESSAGE: foreach my $message ( @$unsent_messages ) {
971 my $message_object = Koha::Notice::Messages->find( $message->{message_id} );
972 # If this fails the database is unwritable and we won't manage to send a message that continues to be marked 'pending'
973 $message_object->make_column_dirty('status');
974 return unless $message_object->store;
976 # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
977 warn sprintf( 'sending %s message to patron: %s',
978 $message->{'message_transport_type'},
979 $message->{'borrowernumber'} || 'Admin' )
980 if $params->{'verbose'} or $debug;
981 # This is just begging for subclassing
982 next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
983 if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
984 _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
986 elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
987 if ( C4::Context->preference('SMSSendDriver') eq 'Email' ) {
988 my $patron = Koha::Patrons->find( $message->{borrowernumber} );
989 my $sms_provider = Koha::SMS::Providers->find( $patron->sms_provider_id );
990 unless ( $sms_provider ) {
991 warn sprintf( "Patron %s has no sms provider id set!", $message->{'borrowernumber'} ) if $params->{'verbose'} or $debug;
992 _set_message_status( { message_id => $message->{'message_id'}, status => 'failed' } );
993 next MESSAGE;
995 unless ( $patron->smsalertnumber ) {
996 _set_message_status( { message_id => $message->{'message_id'}, status => 'failed' } );
997 warn sprintf( "No smsalertnumber found for patron %s!", $message->{'borrowernumber'} ) if $params->{'verbose'} or $debug;
998 next MESSAGE;
1000 $message->{to_address} = $patron->smsalertnumber; #Sometime this is set to email - sms should always use smsalertnumber
1001 $message->{to_address} .= '@' . $sms_provider->domain();
1003 # Check for possible from_address override
1004 my $from_address = C4::Context->preference('EmailSMSSendDriverFromAddress');
1005 if ($from_address && $message->{from_address} ne $from_address) {
1006 $message->{from_address} = $from_address;
1007 _update_message_from_address($message->{'message_id'}, $message->{from_address});
1010 _update_message_to_address($message->{'message_id'}, $message->{to_address});
1011 _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
1012 } else {
1013 _send_message_by_sms( $message );
1017 return scalar( @$unsent_messages );
1020 =head2 GetRSSMessages
1022 my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
1024 returns a listref of all queued RSS messages for a particular person.
1026 =cut
1028 sub GetRSSMessages {
1029 my $params = shift;
1031 return unless $params;
1032 return unless ref $params;
1033 return unless $params->{'borrowernumber'};
1035 return _get_unsent_messages( { message_transport_type => 'rss',
1036 limit => $params->{'limit'},
1037 borrowernumber => $params->{'borrowernumber'}, } );
1040 =head2 GetPrintMessages
1042 my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
1044 Returns a arrayref of all queued print messages (optionally, for a particular
1045 person).
1047 =cut
1049 sub GetPrintMessages {
1050 my $params = shift || {};
1052 return _get_unsent_messages( { message_transport_type => 'print',
1053 borrowernumber => $params->{'borrowernumber'},
1054 } );
1057 =head2 GetQueuedMessages ([$hashref])
1059 my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
1061 Fetches a list of messages from the message queue optionally filtered by borrowernumber
1062 and limited to specified limit.
1064 Return is an arrayref of hashes, each has represents a message in the message queue.
1066 =cut
1068 sub GetQueuedMessages {
1069 my $params = shift;
1071 my $dbh = C4::Context->dbh();
1072 my $statement = << 'ENDSQL';
1073 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued
1074 FROM message_queue
1075 ENDSQL
1077 my @query_params;
1078 my @whereclauses;
1079 if ( exists $params->{'borrowernumber'} ) {
1080 push @whereclauses, ' borrowernumber = ? ';
1081 push @query_params, $params->{'borrowernumber'};
1084 if ( @whereclauses ) {
1085 $statement .= ' WHERE ' . join( 'AND', @whereclauses );
1088 if ( defined $params->{'limit'} ) {
1089 $statement .= ' LIMIT ? ';
1090 push @query_params, $params->{'limit'};
1093 my $sth = $dbh->prepare( $statement );
1094 my $result = $sth->execute( @query_params );
1095 return $sth->fetchall_arrayref({});
1098 =head2 GetMessageTransportTypes
1100 my @mtt = GetMessageTransportTypes();
1102 returns an arrayref of transport types
1104 =cut
1106 sub GetMessageTransportTypes {
1107 my $dbh = C4::Context->dbh();
1108 my $mtts = $dbh->selectcol_arrayref("
1109 SELECT message_transport_type
1110 FROM message_transport_types
1111 ORDER BY message_transport_type
1113 return $mtts;
1116 =head2 GetMessage
1118 my $message = C4::Letters::Message($message_id);
1120 =cut
1122 sub GetMessage {
1123 my ( $message_id ) = @_;
1124 return unless $message_id;
1125 my $dbh = C4::Context->dbh;
1126 return $dbh->selectrow_hashref(q|
1127 SELECT message_id, borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type
1128 FROM message_queue
1129 WHERE message_id = ?
1130 |, {}, $message_id );
1133 =head2 ResendMessage
1135 Attempt to resend a message which has failed previously.
1137 my $has_been_resent = C4::Letters::ResendMessage($message_id);
1139 Updates the message to 'pending' status so that
1140 it will be resent later on.
1142 returns 1 on success, 0 on failure, undef if no message was found
1144 =cut
1146 sub ResendMessage {
1147 my $message_id = shift;
1148 return unless $message_id;
1150 my $message = GetMessage( $message_id );
1151 return unless $message;
1152 my $rv = 0;
1153 if ( $message->{status} ne 'pending' ) {
1154 $rv = C4::Letters::_set_message_status({
1155 message_id => $message_id,
1156 status => 'pending',
1158 $rv = $rv > 0? 1: 0;
1159 # Clear destination email address to force address update
1160 _update_message_to_address( $message_id, undef ) if $rv &&
1161 $message->{message_transport_type} eq 'email';
1163 return $rv;
1166 =head2 _add_attachements
1168 named parameters:
1169 letter - the standard letter hashref
1170 attachments - listref of attachments. each attachment is a hashref of:
1171 type - the mime type, like 'text/plain'
1172 content - the actual attachment
1173 filename - the name of the attachment.
1174 message - a MIME::Lite object to attach these to.
1176 returns your letter object, with the content updated.
1178 =cut
1180 sub _add_attachments {
1181 my $params = shift;
1183 my $letter = $params->{'letter'};
1184 my $attachments = $params->{'attachments'};
1185 return $letter unless @$attachments;
1186 my $message = $params->{'message'};
1188 # First, we have to put the body in as the first attachment
1189 $message->attach(
1190 Type => $letter->{'content-type'} || 'TEXT',
1191 Data => $letter->{'is_html'}
1192 ? _wrap_html($letter->{'content'}, $letter->{'title'})
1193 : $letter->{'content'},
1196 foreach my $attachment ( @$attachments ) {
1197 $message->attach(
1198 Type => $attachment->{'type'},
1199 Data => $attachment->{'content'},
1200 Filename => $attachment->{'filename'},
1203 # we're forcing list context here to get the header, not the count back from grep.
1204 ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
1205 $letter->{'content-type'} =~ s/^Content-Type:\s+//;
1206 $letter->{'content'} = $message->body_as_string;
1208 return $letter;
1212 =head2 _get_unsent_messages
1214 This function's parameter hash reference takes the following
1215 optional named parameters:
1216 message_transport_type: method of message sending (e.g. email, sms, etc.)
1217 borrowernumber : who the message is to be sent
1218 letter_code : type of message being sent (e.g. PASSWORD_RESET)
1219 limit : maximum number of messages to send
1221 This function returns an array of matching hash referenced rows from
1222 message_queue with some borrower information added.
1224 =cut
1226 sub _get_unsent_messages {
1227 my $params = shift;
1229 my $dbh = C4::Context->dbh();
1230 my $statement = qq{
1231 SELECT mq.message_id, mq.borrowernumber, mq.subject, mq.content, mq.message_transport_type, mq.status, mq.time_queued, mq.from_address, mq.to_address, mq.content_type, b.branchcode, mq.letter_code
1232 FROM message_queue mq
1233 LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
1234 WHERE status = ?
1237 my @query_params = ('pending');
1238 if ( ref $params ) {
1239 if ( $params->{'message_transport_type'} ) {
1240 $statement .= ' AND mq.message_transport_type = ? ';
1241 push @query_params, $params->{'message_transport_type'};
1243 if ( $params->{'borrowernumber'} ) {
1244 $statement .= ' AND mq.borrowernumber = ? ';
1245 push @query_params, $params->{'borrowernumber'};
1247 if ( $params->{'letter_code'} ) {
1248 $statement .= ' AND mq.letter_code = ? ';
1249 push @query_params, $params->{'letter_code'};
1251 if ( $params->{'type'} ) {
1252 $statement .= ' AND message_transport_type = ? ';
1253 push @query_params, $params->{'type'};
1255 if ( $params->{'limit'} ) {
1256 $statement .= ' limit ? ';
1257 push @query_params, $params->{'limit'};
1261 $debug and warn "_get_unsent_messages SQL: $statement";
1262 $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
1263 my $sth = $dbh->prepare( $statement );
1264 my $result = $sth->execute( @query_params );
1265 return $sth->fetchall_arrayref({});
1268 sub _send_message_by_email {
1269 my $message = shift or return;
1270 my ($username, $password, $method) = @_;
1272 my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1273 my $to_address = $message->{'to_address'};
1274 unless ($to_address) {
1275 unless ($patron) {
1276 warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
1277 _set_message_status( { message_id => $message->{'message_id'},
1278 status => 'failed' } );
1279 return;
1281 $to_address = $patron->notice_email_address;
1282 unless ($to_address) {
1283 # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
1284 # warning too verbose for this more common case?
1285 _set_message_status( { message_id => $message->{'message_id'},
1286 status => 'failed' } );
1287 return;
1291 # Encode subject line separately
1292 $message->{subject} = encode('MIME-Header', $message->{'subject'} );
1293 my $subject = $message->{'subject'};
1295 my $content = encode('UTF-8', $message->{'content'});
1296 my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
1297 my $is_html = $content_type =~ m/html/io;
1298 my $branch_email = undef;
1299 my $branch_replyto = undef;
1300 my $branch_returnpath = undef;
1301 if ($patron) {
1302 my $library = $patron->library;
1303 $branch_email = $library->branchemail;
1304 $branch_replyto = $library->branchreplyto;
1305 $branch_returnpath = $library->branchreturnpath;
1307 my $email = Koha::Email->new();
1308 my %sendmail_params = $email->create_message_headers(
1310 to => $to_address,
1312 C4::Context->preference('NoticeBcc')
1313 ? ( bcc => C4::Context->preference('NoticeBcc') )
1314 : ()
1316 from => $message->{'from_address'} || $branch_email,
1317 replyto => $branch_replyto,
1318 sender => $branch_returnpath,
1319 subject => $subject,
1320 message => $is_html ? _wrap_html( $content, $subject ) : $content,
1321 contenttype => $content_type
1325 $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
1327 _update_message_to_address($message->{'message_id'},$sendmail_params{To}) if !$message->{to_address} || $message->{to_address} ne $sendmail_params{To}; #if initial message address was empty, coming here means that a to address was found and queue should be updated; same if to address was overriden by create_message_headers
1329 if ( Mail::Sendmail::sendmail( %sendmail_params ) ) {
1330 _set_message_status( { message_id => $message->{'message_id'},
1331 status => 'sent' } );
1332 return 1;
1333 } else {
1334 _set_message_status( { message_id => $message->{'message_id'},
1335 status => 'failed' } );
1336 carp $Mail::Sendmail::error;
1337 return;
1341 sub _wrap_html {
1342 my ($content, $title) = @_;
1344 my $css = C4::Context->preference("NoticeCSS") || '';
1345 $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
1346 return <<EOS;
1347 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1348 "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1349 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1350 <head>
1351 <title>$title</title>
1352 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1353 $css
1354 </head>
1355 <body>
1356 $content
1357 </body>
1358 </html>
1362 sub _is_duplicate {
1363 my ( $message ) = @_;
1364 my $dbh = C4::Context->dbh;
1365 my $count = $dbh->selectrow_array(q|
1366 SELECT COUNT(*)
1367 FROM message_queue
1368 WHERE message_transport_type = ?
1369 AND borrowernumber = ?
1370 AND letter_code = ?
1371 AND CAST(time_queued AS date) = CAST(NOW() AS date)
1372 AND status="sent"
1373 AND content = ?
1374 |, {}, $message->{message_transport_type}, $message->{borrowernumber}, $message->{letter_code}, $message->{content} );
1375 return $count;
1378 sub _send_message_by_sms {
1379 my $message = shift or return;
1380 my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1382 unless ( $patron and $patron->smsalertnumber ) {
1383 _set_message_status( { message_id => $message->{'message_id'},
1384 status => 'failed' } );
1385 return;
1388 if ( _is_duplicate( $message ) ) {
1389 _set_message_status( { message_id => $message->{'message_id'},
1390 status => 'failed' } );
1391 return;
1394 my $success = C4::SMS->send_sms( { destination => $patron->smsalertnumber,
1395 message => $message->{'content'},
1396 } );
1397 _set_message_status( { message_id => $message->{'message_id'},
1398 status => ($success ? 'sent' : 'failed') } );
1399 return $success;
1402 sub _update_message_to_address {
1403 my ($id, $to)= @_;
1404 my $dbh = C4::Context->dbh();
1405 $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1408 sub _update_message_from_address {
1409 my ($message_id, $from_address) = @_;
1410 my $dbh = C4::Context->dbh();
1411 $dbh->do('UPDATE message_queue SET from_address = ? WHERE message_id = ?', undef, ($from_address, $message_id));
1414 sub _set_message_status {
1415 my $params = shift or return;
1417 foreach my $required_parameter ( qw( message_id status ) ) {
1418 return unless exists $params->{ $required_parameter };
1421 my $dbh = C4::Context->dbh();
1422 my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1423 my $sth = $dbh->prepare( $statement );
1424 my $result = $sth->execute( $params->{'status'},
1425 $params->{'message_id'} );
1426 return $result;
1429 sub _process_tt {
1430 my ( $params ) = @_;
1432 my $content = $params->{content};
1433 my $tables = $params->{tables};
1434 my $loops = $params->{loops};
1435 my $substitute = $params->{substitute} || {};
1437 my $use_template_cache = C4::Context->config('template_cache_dir') && defined $ENV{GATEWAY_INTERFACE};
1438 my $template = Template->new(
1440 EVAL_PERL => 1,
1441 ABSOLUTE => 1,
1442 PLUGIN_BASE => 'Koha::Template::Plugin',
1443 COMPILE_EXT => $use_template_cache ? '.ttc' : '',
1444 COMPILE_DIR => $use_template_cache ? C4::Context->config('template_cache_dir') : '',
1445 FILTERS => {},
1446 ENCODING => 'UTF-8',
1448 ) or die Template->error();
1450 my $tt_params = { %{ _get_tt_params( $tables ) }, %{ _get_tt_params( $loops, 'is_a_loop' ) }, %$substitute };
1452 $content = add_tt_filters( $content );
1453 $content = qq|[% USE KohaDates %][% USE Remove_MARC_punctuation %]$content|;
1455 my $output;
1456 $template->process( \$content, $tt_params, \$output ) || croak "ERROR PROCESSING TEMPLATE: " . $template->error();
1458 return $output;
1461 sub _get_tt_params {
1462 my ($tables, $is_a_loop) = @_;
1464 my $params;
1465 $is_a_loop ||= 0;
1467 my $config = {
1468 article_requests => {
1469 module => 'Koha::ArticleRequests',
1470 singular => 'article_request',
1471 plural => 'article_requests',
1472 pk => 'id',
1474 biblio => {
1475 module => 'Koha::Biblios',
1476 singular => 'biblio',
1477 plural => 'biblios',
1478 pk => 'biblionumber',
1480 biblioitems => {
1481 module => 'Koha::Biblioitems',
1482 singular => 'biblioitem',
1483 plural => 'biblioitems',
1484 pk => 'biblioitemnumber',
1486 borrowers => {
1487 module => 'Koha::Patrons',
1488 singular => 'borrower',
1489 plural => 'borrowers',
1490 pk => 'borrowernumber',
1492 branches => {
1493 module => 'Koha::Libraries',
1494 singular => 'branch',
1495 plural => 'branches',
1496 pk => 'branchcode',
1498 items => {
1499 module => 'Koha::Items',
1500 singular => 'item',
1501 plural => 'items',
1502 pk => 'itemnumber',
1504 opac_news => {
1505 module => 'Koha::News',
1506 singular => 'news',
1507 plural => 'news',
1508 pk => 'idnew',
1510 aqorders => {
1511 module => 'Koha::Acquisition::Orders',
1512 singular => 'order',
1513 plural => 'orders',
1514 pk => 'ordernumber',
1516 reserves => {
1517 module => 'Koha::Holds',
1518 singular => 'hold',
1519 plural => 'holds',
1520 fk => [ 'borrowernumber', 'biblionumber' ],
1522 serial => {
1523 module => 'Koha::Serials',
1524 singular => 'serial',
1525 plural => 'serials',
1526 pk => 'serialid',
1528 subscription => {
1529 module => 'Koha::Subscriptions',
1530 singular => 'subscription',
1531 plural => 'subscriptions',
1532 pk => 'subscriptionid',
1534 suggestions => {
1535 module => 'Koha::Suggestions',
1536 singular => 'suggestion',
1537 plural => 'suggestions',
1538 pk => 'suggestionid',
1540 issues => {
1541 module => 'Koha::Checkouts',
1542 singular => 'checkout',
1543 plural => 'checkouts',
1544 fk => 'itemnumber',
1546 old_issues => {
1547 module => 'Koha::Old::Checkouts',
1548 singular => 'old_checkout',
1549 plural => 'old_checkouts',
1550 fk => 'itemnumber',
1552 overdues => {
1553 module => 'Koha::Checkouts',
1554 singular => 'overdue',
1555 plural => 'overdues',
1556 fk => 'itemnumber',
1558 borrower_modifications => {
1559 module => 'Koha::Patron::Modifications',
1560 singular => 'patron_modification',
1561 plural => 'patron_modifications',
1562 fk => 'verification_token',
1566 foreach my $table ( keys %$tables ) {
1567 next unless $config->{$table};
1569 my $ref = ref( $tables->{$table} ) || q{};
1570 my $module = $config->{$table}->{module};
1572 if ( can_load( modules => { $module => undef } ) ) {
1573 my $pk = $config->{$table}->{pk};
1574 my $fk = $config->{$table}->{fk};
1576 if ( $is_a_loop ) {
1577 my $values = $tables->{$table} || [];
1578 unless ( ref( $values ) eq 'ARRAY' ) {
1579 croak "ERROR processing table $table. Wrong API call.";
1581 my $key = $pk ? $pk : $fk;
1582 # $key does not come from user input
1583 my $objects = $module->search(
1584 { $key => $values },
1586 # We want to retrieve the data in the same order
1587 # FIXME MySQLism
1588 # field is a MySQLism, but they are no other way to do it
1589 # To be generic we could do it in perl, but we will need to fetch
1590 # all the data then order them
1591 @$values ? ( order_by => \[ "field($key, " . join( ', ', @$values ) . ")" ] ) : ()
1594 $params->{ $config->{$table}->{plural} } = $objects;
1596 elsif ( $ref eq q{} || $ref eq 'HASH' ) {
1597 my $id = ref $ref eq 'HASH' ? $tables->{$table}->{$pk} : $tables->{$table};
1598 my $object;
1599 if ( $fk ) { # Using a foreign key for lookup
1600 if ( ref( $fk ) eq 'ARRAY' ) { # Foreign key is multi-column
1601 my $search;
1602 foreach my $key ( @$fk ) {
1603 $search->{$key} = $id->{$key};
1605 $object = $module->search( $search )->last();
1606 } else { # Foreign key is single column
1607 $object = $module->search( { $fk => $id } )->last();
1609 } else { # using the table's primary key for lookup
1610 $object = $module->find($id);
1612 $params->{ $config->{$table}->{singular} } = $object;
1614 else { # $ref eq 'ARRAY'
1615 my $object;
1616 if ( @{ $tables->{$table} } == 1 ) { # Param is a single key
1617 $object = $module->search( { $pk => $tables->{$table} } )->last();
1619 else { # Params are mutliple foreign keys
1620 croak "Multiple foreign keys (table $table) should be passed using an hashref";
1622 $params->{ $config->{$table}->{singular} } = $object;
1625 else {
1626 croak "ERROR LOADING MODULE $module: $Module::Load::Conditional::ERROR";
1630 $params->{today} = output_pref({ dt => dt_from_string, dateformat => 'iso' });
1632 return $params;
1635 =head3 add_tt_filters
1637 $content = add_tt_filters( $content );
1639 Add TT filters to some specific fields if needed.
1641 For now we only add the Remove_MARC_punctuation TT filter to biblio and biblioitem fields
1643 =cut
1645 sub add_tt_filters {
1646 my ( $content ) = @_;
1647 $content =~ s|\[%\s*biblio\.(.*?)\s*%\]|[% biblio.$1 \| \$Remove_MARC_punctuation %]|gxms;
1648 $content =~ s|\[%\s*biblioitem\.(.*?)\s*%\]|[% biblioitem.$1 \| \$Remove_MARC_punctuation %]|gxms;
1649 return $content;
1652 =head2 get_item_content
1654 my $item = Koha::Items->find(...)->unblessed;
1655 my @item_content_fields = qw( date_due title barcode author itemnumber );
1656 my $item_content = C4::Letters::get_item_content({
1657 item => $item,
1658 item_content_fields => \@item_content_fields
1661 This function generates a tab-separated list of values for the passed item. Dates
1662 are formatted following the current setup.
1664 =cut
1666 sub get_item_content {
1667 my ( $params ) = @_;
1668 my $item = $params->{item};
1669 my $dateonly = $params->{dateonly} || 0;
1670 my $item_content_fields = $params->{item_content_fields} || [];
1672 return unless $item;
1674 my @item_info = map {
1675 $_ =~ /^date|date$/
1676 ? eval {
1677 output_pref(
1678 { dt => dt_from_string( $item->{$_} ), dateonly => $dateonly } );
1680 : $item->{$_}
1681 || ''
1682 } @$item_content_fields;
1683 return join( "\t", @item_info ) . "\n";
1687 __END__