Bug 5770: Unit test
[koha.git] / C4 / Letters.pm
1 package C4::Letters;
2
3 # Copyright 2000-2002 Katipo Communications
4 #
5 # This file is part of Koha.
6 #
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.
11 #
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.
16 #
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>.
19
20 use Modern::Perl;
21
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);
29
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;
37
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;
43
44 use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
45
46 BEGIN {
47     require Exporter;
48     @ISA = qw(Exporter);
49     @EXPORT = qw(
50         &GetLetters &GetLettersAvailableForALibrary &GetLetterTemplates &DelLetter &GetPreparedLetter &GetWrappedLetter &SendAlerts &GetPrintMessages &GetMessageTransportTypes
51     );
52 }
53
54 =head1 NAME
55
56 C4::Letters - Give functions for Letters management
57
58 =head1 SYNOPSIS
59
60   use C4::Letters;
61
62 =head1 DESCRIPTION
63
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)
66
67   Letters are managed through "alerts" sent by Koha on some events. All "alert" related functions are in this module too.
68
69 =head2 GetLetters([$module])
70
71   $letters = &GetLetters($module);
72   returns informations about letters.
73   if needed, $module filters for letters given module
74
75   DEPRECATED - You must use Koha::Notice::Templates instead
76   The group by clause is confusing and can lead to issues
77
78 =cut
79
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(
87         q|
88             SELECT code, module, name
89             FROM letter
90             WHERE 1
91         |
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 : () )
99     );
100
101     return $letters;
102 }
103
104 =head2 GetLetterTemplates
105
106     my $letter_templates = GetLetterTemplates(
107         {
108             module => 'circulation',
109             code => 'my code',
110             branchcode => 'CPL', # '' for default,
111         }
112     );
113
114     Return a hashref of letter templates.
115
116 =cut
117
118 sub GetLetterTemplates {
119     my ( $params ) = @_;
120
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(
126         q|
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 = ?
132         |
133         , { Slice => {} }
134         , $module, $code, $branchcode
135     );
136
137     return $letters;
138 }
139
140 =head2 GetLettersAvailableForALibrary
141
142     my $letters = GetLettersAvailableForALibrary(
143         {
144             branchcode => 'CPL', # '' for default
145             module => 'circulation',
146         }
147     );
148
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.
152
153 =cut
154
155 sub GetLettersAvailableForALibrary {
156     my ($filters)  = @_;
157     my $branchcode = $filters->{branchcode};
158     my $module     = $filters->{module};
159
160     croak "module should be provided" unless $module;
161
162     my $dbh             = C4::Context->dbh;
163     my $default_letters = $dbh->selectall_arrayref(
164         q|
165             SELECT module, code, branchcode, name
166             FROM letter
167             WHERE 1
168         |
169           . q| AND branchcode = ''|
170           . ( $module ? q| AND module = ?| : q|| )
171           . q| ORDER BY name|, { Slice => {} }
172         , ( $module ? $module : () )
173     );
174
175     my $specific_letters;
176     if ($branchcode) {
177         $specific_letters = $dbh->selectall_arrayref(
178             q|
179                 SELECT module, code, branchcode, name
180                 FROM letter
181                 WHERE 1
182             |
183               . q| AND branchcode = ?|
184               . ( $module ? q| AND module = ?| : q|| )
185               . q| ORDER BY name|, { Slice => {} }
186             , $branchcode
187             , ( $module ? $module : () )
188         );
189     }
190
191     my %letters;
192     for my $l (@$default_letters) {
193         $letters{ $l->{code} } = $l;
194     }
195     for my $l (@$specific_letters) {
196         # Overwrite the default letter with the specific one.
197         $letters{ $l->{code} } = $l;
198     }
199
200     return [ map { $letters{$_} }
201           sort { $letters{$a}->{name} cmp $letters{$b}->{name} }
202           keys %letters ];
203
204 }
205
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') );
210
211
212     my $only_my_library = C4::Context->only_my_library;
213     if ( $only_my_library and $branchcode ) {
214         $branchcode = C4::Context::mybranch();
215     }
216     $branchcode //= '';
217
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
226     });
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 };
232 }
233
234
235 =head2 DelLetter
236
237     DelLetter(
238         {
239             branchcode => 'CPL',
240             module => 'circulation',
241             code => 'my code',
242             [ mtt => 'email', ]
243         }
244     );
245
246     Delete the letter. The mtt parameter is facultative.
247     If not given, all templates mathing the other parameters will be removed.
248
249 =cut
250
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 = ?
264     |
265     . ( $mtt ? q| AND message_transport_type = ?| : q|| )
266     . ( $lang? q| AND lang = ?| : q|| )
267     , undef, $branchcode, $module, $code, ( $mtt ? $mtt : () ), ( $lang ? $lang : () ) );
268 }
269
270 =head2 SendAlerts
271
272     my $err = &SendAlerts($type, $externalid, $letter_code);
273
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
278
279     C<&SendAlerts> sends an email notice directly to a patron or a vendor.
280
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)
287
288     Returns undef or { error => 'message } on failure.
289     Returns true on success.
290
291 =cut
292
293 sub SendAlerts {
294     my ( $type, $externalid, $letter_code ) = @_;
295     my $dbh = C4::Context->dbh;
296     if ( $type eq 'issue' ) {
297
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;
307
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;
316
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;
323
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,
338                 },
339                 want_librarian => 1,
340             ) or return;
341
342             # ... then send mail
343             my $message = Koha::Email->new();
344             my %mail = $message->create_message_headers(
345                 {
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"',
358                 }
359             );
360             unless( Mail::Sendmail::sendmail(%mail) ) {
361                 carp $Mail::Sendmail::error;
362                 return { error => $Mail::Sendmail::error };
363             }
364         }
365     }
366     elsif ( $type eq 'claimacquisition' or $type eq 'claimissues' or $type eq 'orderacquisition' ) {
367
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 (
381             };
382
383             if (!@$externalid){
384                 carp "No order selected";
385                 return { error => "no_order_selected" };
386             }
387             $strsth .= join( ",", ('?') x @$externalid ) . ")";
388             $action = "ACQUISITION CLAIM";
389             $sthorders = $dbh->prepare($strsth);
390             $sthorders->execute( @$externalid );
391             $dataorders = $sthorders->fetchall_arrayref( {} );
392         }
393
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 (
404             };
405
406             if (!@$externalid){
407                 carp "No issues selected";
408                 return { error => "no_issues_selected" };
409             }
410
411             $strsth .= join( ",", ('?') x @$externalid ) . ")";
412             $action = "SERIAL CLAIM";
413             $sthorders = $dbh->prepare($strsth);
414             $sthorders->execute( @$externalid );
415             $dataorders = $sthorders->fetchall_arrayref( {} );
416         }
417
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')
427             };
428
429             if (!$externalid){
430                 carp "No basketnumber given";
431                 return { error => "no_basketno" };
432             }
433             $action = "ACQUISITION ORDER";
434             $sthorders = $dbh->prepare($strsth);
435             $sthorders->execute($externalid);
436             $dataorders = $sthorders->fetchall_arrayref( {} );
437         }
438
439         my $sthbookseller =
440           $dbh->prepare("select * from aqbooksellers where id=?");
441         $sthbookseller->execute( $dataorders->[0]->{booksellerid} );
442         my $databookseller = $sthbookseller->fetchrow_hashref;
443
444         my $addressee =  $type eq 'claimacquisition' || $type eq 'orderacquisition' ? 'acqprimary' : 'serialsprimary';
445
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;
450
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" };
458         }
459         my $addlcontact;
460         while ($addlcontact = $sthcontact->fetchrow_hashref) {
461             push @cc, $addlcontact->{email} if ( $addlcontact && $addlcontact->{email} );
462         }
463
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,
473             },
474             repeat => $dataorders,
475             want_librarian => 1,
476         ) or return { error => "no_letter" };
477
478         # Remove the order tag
479         $letter->{content} =~ s/<order>(.*?)<\/order>/$1/gxms;
480
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(
485             {
486                 to => join( ',', @email ),
487                 cc => join( ',', @cc ),
488                 (
489                     (
490                         C4::Context->preference("ClaimsBccCopy")
491                           && ( $type eq 'claimacquisition'
492                             || $type eq 'claimissues' )
493                     ) ? ( bcc => $userenv->{emailaddress} )
494                     : ()
495                 ),
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'} )
502                   )
503                 : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
504                 contenttype => $letter->{'is_html'}
505                 ? 'text/html; charset="utf-8"'
506                 : 'text/plain; charset="utf-8"',
507             }
508         );
509
510         unless ( Mail::Sendmail::sendmail(%mail) ) {
511             carp $Mail::Sendmail::error;
512             return { error => $Mail::Sendmail::error };
513         }
514
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");
526     }
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'},
538             },
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(
545             {
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"',
558             }
559         );
560         unless( Mail::Sendmail::sendmail(%mail) ) {
561             carp $Mail::Sendmail::error;
562             return { error => $Mail::Sendmail::error };
563         }
564     }
565
566     # If we come here, return an OK status
567     return 1;
568 }
569
570 =head2 GetPreparedLetter( %params )
571
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)
590
591 =cut
592
593 sub GetPreparedLetter {
594     my %params = @_;
595
596     my $letter = $params{letter};
597
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';
604
605         $letter = getletter( $module, $letter_code, $branchcode, $mtt, $lang );
606
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;
611         }
612     }
613
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};
622
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};
627             }
628
629             $letter->{title} =~ s/<<$token>>/$val/g;
630             $letter->{content} =~ s/<<$token>>/$val/g;
631        }
632     }
633
634     my $OPACBaseURL = C4::Context->preference('OPACBaseURL');
635     $letter->{content} =~ s/<<OPACBaseURL>>/$OPACBaseURL/go;
636
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;
643     }
644
645     my ($repeat_no_enclosing_tags, $repeat_enclosing_tags);
646
647     if ($repeat) {
648         if (ref ($repeat) eq 'ARRAY' ) {
649             $repeat_no_enclosing_tags = $repeat;
650         } else {
651             $repeat_enclosing_tags = $repeat;
652         }
653     }
654
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;
665             }
666         }
667     }
668
669     if (%$tables) {
670         _substitute_tables( $letter, $tables );
671     }
672
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}/;
682                 }
683                 $i++;
684                 $c;
685             } @$repeat_no_enclosing_tags;
686
687             my $replaceby = join( "\n", @lines );
688             $letter->{content} =~ s/\Q$line\E/$replaceby/s;
689         }
690     }
691
692     $letter->{content} = _process_tt(
693         {
694             content => $letter->{content},
695             tables  => $tables,
696             loops  => $loops,
697             substitute => $substitute,
698         }
699     );
700
701     $letter->{content} =~ s/<<\S*>>//go; #remove any stragglers
702
703     return $letter;
704 }
705
706 sub _substitute_tables {
707     my ( $letter, $tables ) = @_;
708     while ( my ($table, $param) = each %$tables ) {
709         next unless $param;
710
711         my $ref = ref $param;
712
713         my $values;
714         if ($ref && $ref eq 'HASH') {
715             $values = $param;
716         }
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;
722             }
723             $sth->execute( $ref ? @$param : $param );
724
725             $values = $sth->fetchrow_hashref;
726             $sth->finish();
727         }
728
729         _parseletter ( $letter, $table, $values );
730     }
731 }
732
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;
739     }
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
765     }
766     unless ($sth = C4::Context->dbh->prepare_cached($query)) {
767         warn "ERROR: Failed to prepare query: '$query'";
768         return;
769     }
770     return $sth;    # now cache is populated for that $table
771 }
772
773 =head2 _parseletter($letter, $table, $values)
774
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)
781
782 =cut
783
784 sub _parseletter {
785     my ( $letter, $table, $values_in ) = @_;
786
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 } : {};
790
791     if ( $table eq 'borrowers' && $values->{'dateexpiry'} ){
792         $values->{'dateexpiry'} = output_pref({ dt => dt_from_string( $values->{'dateexpiry'} ), dateonly => 1 });
793     }
794
795     if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
796         $values->{'waitingdate'} = output_pref({ dt => dt_from_string( $values->{'waitingdate'} ), dateonly => 1 });
797     }
798
799     if ($letter->{content} && $letter->{content} =~ /<<today>>/) {
800         my $todaysdate = output_pref( DateTime->now() );
801         $letter->{content} =~ s/<<today>>/$todaysdate/go;
802     }
803
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.
809
810         if ( $table=~/^borrowers$/ && $field=~/^streettype$/ ) {
811             my $av = Koha::AuthorisedValues->search({ category => 'ROADTYPE', authorised_value => $val });
812             $val = $av->count ? $av->next->lib : '';
813         }
814
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})?$| )
821         {
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;
825
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;
832                 }
833                 my $replacedby_date = eval {
834                     output_pref({ dt => dt_from_string( $replacedby ), dateonly => $dateonly });
835                 };
836
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;
840                 }
841             }
842         }
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;
849                 }
850             }
851         }
852     }
853
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;
864             }
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;
869             }
870         }
871     }
872     return $letter;
873 }
874
875 =head2 EnqueueLetter
876
877   my $success = EnqueueLetter( { letter => $letter, 
878         borrowernumber => '12', message_transport_type => 'email' } )
879
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.
883
884 return message_id on success
885
886 =cut
887
888 sub EnqueueLetter {
889     my $params = shift or return;
890
891     return unless exists $params->{'letter'};
892 #   return unless exists $params->{'borrowernumber'};
893     return unless exists $params->{'message_transport_type'};
894
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;
900     }
901
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' ),
908             }
909         );
910     }
911
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
919
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
932     );
933     return $dbh->last_insert_id(undef,undef,'message_queue', undef);
934 }
935
936 =head2 SendQueuedMessages ([$hashref]) 
937
938     my $sent = SendQueuedMessages({
939         letter_code => $letter_code,
940         borrowernumber => $who_letter_is_for,
941         limit => 50,
942         verbose => 1,
943         type => 'sms',
944     });
945
946 Sends all of the 'pending' items in the message queue, unless
947 parameters are passed.
948
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.
952
953 The verbose parameter can be used to generate debugging output.
954 It is also optional.
955
956 Returns number of messages sent.
957
958 =cut
959
960 sub SendQueuedMessages {
961     my $params = shift;
962
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{},
968     };
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;
975
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'} );
985         }
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;
994                 }
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;
999                 }
1000                 $message->{to_address}  = $patron->smsalertnumber; #Sometime this is set to email - sms should always use smsalertnumber
1001                 $message->{to_address} .= '@' . $sms_provider->domain();
1002
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});
1008                 }
1009
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 );
1014             }
1015         }
1016     }
1017     return scalar( @$unsent_messages );
1018 }
1019
1020 =head2 GetRSSMessages
1021
1022   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
1023
1024 returns a listref of all queued RSS messages for a particular person.
1025
1026 =cut
1027
1028 sub GetRSSMessages {
1029     my $params = shift;
1030
1031     return unless $params;
1032     return unless ref $params;
1033     return unless $params->{'borrowernumber'};
1034     
1035     return _get_unsent_messages( { message_transport_type => 'rss',
1036                                    limit                  => $params->{'limit'},
1037                                    borrowernumber         => $params->{'borrowernumber'}, } );
1038 }
1039
1040 =head2 GetPrintMessages
1041
1042   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
1043
1044 Returns a arrayref of all queued print messages (optionally, for a particular
1045 person).
1046
1047 =cut
1048
1049 sub GetPrintMessages {
1050     my $params = shift || {};
1051     
1052     return _get_unsent_messages( { message_transport_type => 'print',
1053                                    borrowernumber         => $params->{'borrowernumber'},
1054                                  } );
1055 }
1056
1057 =head2 GetQueuedMessages ([$hashref])
1058
1059   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
1060
1061 fetches messages out of the message queue.
1062
1063 returns:
1064 list of hashes, each has represents a message in the message queue.
1065
1066 =cut
1067
1068 sub GetQueuedMessages {
1069     my $params = shift;
1070
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
1076
1077     my @query_params;
1078     my @whereclauses;
1079     if ( exists $params->{'borrowernumber'} ) {
1080         push @whereclauses, ' borrowernumber = ? ';
1081         push @query_params, $params->{'borrowernumber'};
1082     }
1083
1084     if ( exists $params->{'letter_code'} ) {
1085         push @whereclauses, ' letter_code = ? ';
1086         push @query_params, $params->{'letter_code'};
1087     }
1088
1089     if ( @whereclauses ) {
1090         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
1091     }
1092
1093     if ( defined $params->{'limit'} ) {
1094         $statement .= ' LIMIT ? ';
1095         push @query_params, $params->{'limit'};
1096     }
1097
1098     my $sth = $dbh->prepare( $statement );
1099     my $result = $sth->execute( @query_params );
1100     return $sth->fetchall_arrayref({});
1101 }
1102
1103 =head2 GetMessageTransportTypes
1104
1105   my @mtt = GetMessageTransportTypes();
1106
1107   returns an arrayref of transport types
1108
1109 =cut
1110
1111 sub GetMessageTransportTypes {
1112     my $dbh = C4::Context->dbh();
1113     my $mtts = $dbh->selectcol_arrayref("
1114         SELECT message_transport_type
1115         FROM message_transport_types
1116         ORDER BY message_transport_type
1117     ");
1118     return $mtts;
1119 }
1120
1121 =head2 GetMessage
1122
1123     my $message = C4::Letters::Message($message_id);
1124
1125 =cut
1126
1127 sub GetMessage {
1128     my ( $message_id ) = @_;
1129     return unless $message_id;
1130     my $dbh = C4::Context->dbh;
1131     return $dbh->selectrow_hashref(q|
1132         SELECT message_id, borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type
1133         FROM message_queue
1134         WHERE message_id = ?
1135     |, {}, $message_id );
1136 }
1137
1138 =head2 ResendMessage
1139
1140   Attempt to resend a message which has failed previously.
1141
1142   my $has_been_resent = C4::Letters::ResendMessage($message_id);
1143
1144   Updates the message to 'pending' status so that
1145   it will be resent later on.
1146
1147   returns 1 on success, 0 on failure, undef if no message was found
1148
1149 =cut
1150
1151 sub ResendMessage {
1152     my $message_id = shift;
1153     return unless $message_id;
1154
1155     my $message = GetMessage( $message_id );
1156     return unless $message;
1157     my $rv = 0;
1158     if ( $message->{status} ne 'pending' ) {
1159         $rv = C4::Letters::_set_message_status({
1160             message_id => $message_id,
1161             status => 'pending',
1162         });
1163         $rv = $rv > 0? 1: 0;
1164         # Clear destination email address to force address update
1165         _update_message_to_address( $message_id, undef ) if $rv &&
1166             $message->{message_transport_type} eq 'email';
1167     }
1168     return $rv;
1169 }
1170
1171 =head2 _add_attachements
1172
1173   named parameters:
1174   letter - the standard letter hashref
1175   attachments - listref of attachments. each attachment is a hashref of:
1176     type - the mime type, like 'text/plain'
1177     content - the actual attachment
1178     filename - the name of the attachment.
1179   message - a MIME::Lite object to attach these to.
1180
1181   returns your letter object, with the content updated.
1182
1183 =cut
1184
1185 sub _add_attachments {
1186     my $params = shift;
1187
1188     my $letter = $params->{'letter'};
1189     my $attachments = $params->{'attachments'};
1190     return $letter unless @$attachments;
1191     my $message = $params->{'message'};
1192
1193     # First, we have to put the body in as the first attachment
1194     $message->attach(
1195         Type => $letter->{'content-type'} || 'TEXT',
1196         Data => $letter->{'is_html'}
1197             ? _wrap_html($letter->{'content'}, $letter->{'title'})
1198             : $letter->{'content'},
1199     );
1200
1201     foreach my $attachment ( @$attachments ) {
1202         $message->attach(
1203             Type     => $attachment->{'type'},
1204             Data     => $attachment->{'content'},
1205             Filename => $attachment->{'filename'},
1206         );
1207     }
1208     # we're forcing list context here to get the header, not the count back from grep.
1209     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
1210     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
1211     $letter->{'content'} = $message->body_as_string;
1212
1213     return $letter;
1214
1215 }
1216
1217 =head2 _get_unsent_messages
1218
1219   This function's parameter hash reference takes the following
1220   optional named parameters:
1221    message_transport_type: method of message sending (e.g. email, sms, etc.)
1222    borrowernumber        : who the message is to be sent
1223    letter_code           : type of message being sent (e.g. PASSWORD_RESET)
1224    limit                 : maximum number of messages to send
1225
1226   This function returns an array of matching hash referenced rows from
1227   message_queue with some borrower information added.
1228
1229 =cut
1230
1231 sub _get_unsent_messages {
1232     my $params = shift;
1233
1234     my $dbh = C4::Context->dbh();
1235     my $statement = qq{
1236         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
1237         FROM message_queue mq
1238         LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
1239         WHERE status = ?
1240     };
1241
1242     my @query_params = ('pending');
1243     if ( ref $params ) {
1244         if ( $params->{'message_transport_type'} ) {
1245             $statement .= ' AND mq.message_transport_type = ? ';
1246             push @query_params, $params->{'message_transport_type'};
1247         }
1248         if ( $params->{'borrowernumber'} ) {
1249             $statement .= ' AND mq.borrowernumber = ? ';
1250             push @query_params, $params->{'borrowernumber'};
1251         }
1252         if ( $params->{'letter_code'} ) {
1253             $statement .= ' AND mq.letter_code = ? ';
1254             push @query_params, $params->{'letter_code'};
1255         }
1256         if ( $params->{'type'} ) {
1257             $statement .= ' AND message_transport_type = ? ';
1258             push @query_params, $params->{'type'};
1259         }
1260         if ( $params->{'limit'} ) {
1261             $statement .= ' limit ? ';
1262             push @query_params, $params->{'limit'};
1263         }
1264     }
1265
1266     $debug and warn "_get_unsent_messages SQL: $statement";
1267     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
1268     my $sth = $dbh->prepare( $statement );
1269     my $result = $sth->execute( @query_params );
1270     return $sth->fetchall_arrayref({});
1271 }
1272
1273 sub _send_message_by_email {
1274     my $message = shift or return;
1275     my ($username, $password, $method) = @_;
1276
1277     my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1278     my $to_address = $message->{'to_address'};
1279     unless ($to_address) {
1280         unless ($patron) {
1281             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
1282             _set_message_status( { message_id => $message->{'message_id'},
1283                                    status     => 'failed' } );
1284             return;
1285         }
1286         $to_address = $patron->notice_email_address;
1287         unless ($to_address) {  
1288             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
1289             # warning too verbose for this more common case?
1290             _set_message_status( { message_id => $message->{'message_id'},
1291                                    status     => 'failed' } );
1292             return;
1293         }
1294     }
1295
1296     # Encode subject line separately
1297     $message->{subject} = encode('MIME-Header', $message->{'subject'} );
1298     my $subject = $message->{'subject'};
1299
1300     my $content = encode('UTF-8', $message->{'content'});
1301     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
1302     my $is_html = $content_type =~ m/html/io;
1303     my $branch_email = undef;
1304     my $branch_replyto = undef;
1305     my $branch_returnpath = undef;
1306     if ($patron) {
1307         my $library = $patron->library;
1308         $branch_email      = $library->branchemail;
1309         $branch_replyto    = $library->branchreplyto;
1310         $branch_returnpath = $library->branchreturnpath;
1311     }
1312     my $email = Koha::Email->new();
1313     my %sendmail_params = $email->create_message_headers(
1314         {
1315             to => $to_address,
1316             (
1317                 C4::Context->preference('NoticeBcc')
1318                 ? ( bcc => C4::Context->preference('NoticeBcc') )
1319                 : ()
1320             ),
1321             from    => $message->{'from_address'} || $branch_email,
1322             replyto => $branch_replyto,
1323             sender  => $branch_returnpath,
1324             subject => $subject,
1325             message => $is_html ? _wrap_html( $content, $subject ) : $content,
1326             contenttype => $content_type
1327         }
1328     );
1329
1330     $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
1331
1332     _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
1333
1334     if ( Mail::Sendmail::sendmail( %sendmail_params ) ) {
1335         _set_message_status( { message_id => $message->{'message_id'},
1336                 status     => 'sent' } );
1337         return 1;
1338     } else {
1339         _set_message_status( { message_id => $message->{'message_id'},
1340                 status     => 'failed' } );
1341         carp $Mail::Sendmail::error;
1342         return;
1343     }
1344 }
1345
1346 sub _wrap_html {
1347     my ($content, $title) = @_;
1348
1349     my $css = C4::Context->preference("NoticeCSS") || '';
1350     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
1351     return <<EOS;
1352 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1353     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1354 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1355 <head>
1356 <title>$title</title>
1357 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1358 $css
1359 </head>
1360 <body>
1361 $content
1362 </body>
1363 </html>
1364 EOS
1365 }
1366
1367 sub _is_duplicate {
1368     my ( $message ) = @_;
1369     my $dbh = C4::Context->dbh;
1370     my $count = $dbh->selectrow_array(q|
1371         SELECT COUNT(*)
1372         FROM message_queue
1373         WHERE message_transport_type = ?
1374         AND borrowernumber = ?
1375         AND letter_code = ?
1376         AND CAST(time_queued AS date) = CAST(NOW() AS date)
1377         AND status="sent"
1378         AND content = ?
1379     |, {}, $message->{message_transport_type}, $message->{borrowernumber}, $message->{letter_code}, $message->{content} );
1380     return $count;
1381 }
1382
1383 sub _send_message_by_sms {
1384     my $message = shift or return;
1385     my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1386
1387     unless ( $patron and $patron->smsalertnumber ) {
1388         _set_message_status( { message_id => $message->{'message_id'},
1389                                status     => 'failed' } );
1390         return;
1391     }
1392
1393     if ( _is_duplicate( $message ) ) {
1394         _set_message_status( { message_id => $message->{'message_id'},
1395                                status     => 'failed' } );
1396         return;
1397     }
1398
1399     my $success = C4::SMS->send_sms( { destination => $patron->smsalertnumber,
1400                                        message     => $message->{'content'},
1401                                      } );
1402     _set_message_status( { message_id => $message->{'message_id'},
1403                            status     => ($success ? 'sent' : 'failed') } );
1404     return $success;
1405 }
1406
1407 sub _update_message_to_address {
1408     my ($id, $to)= @_;
1409     my $dbh = C4::Context->dbh();
1410     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1411 }
1412
1413 sub _update_message_from_address {
1414     my ($message_id, $from_address) = @_;
1415     my $dbh = C4::Context->dbh();
1416     $dbh->do('UPDATE message_queue SET from_address = ? WHERE message_id = ?', undef, ($from_address, $message_id));
1417 }
1418
1419 sub _set_message_status {
1420     my $params = shift or return;
1421
1422     foreach my $required_parameter ( qw( message_id status ) ) {
1423         return unless exists $params->{ $required_parameter };
1424     }
1425
1426     my $dbh = C4::Context->dbh();
1427     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1428     my $sth = $dbh->prepare( $statement );
1429     my $result = $sth->execute( $params->{'status'},
1430                                 $params->{'message_id'} );
1431     return $result;
1432 }
1433
1434 sub _process_tt {
1435     my ( $params ) = @_;
1436
1437     my $content = $params->{content};
1438     my $tables = $params->{tables};
1439     my $loops = $params->{loops};
1440     my $substitute = $params->{substitute} || {};
1441
1442     my $use_template_cache = C4::Context->config('template_cache_dir') && defined $ENV{GATEWAY_INTERFACE};
1443     my $template           = Template->new(
1444         {
1445             EVAL_PERL    => 1,
1446             ABSOLUTE     => 1,
1447             PLUGIN_BASE  => 'Koha::Template::Plugin',
1448             COMPILE_EXT  => $use_template_cache ? '.ttc' : '',
1449             COMPILE_DIR  => $use_template_cache ? C4::Context->config('template_cache_dir') : '',
1450             FILTERS      => {},
1451             ENCODING     => 'UTF-8',
1452         }
1453     ) or die Template->error();
1454
1455     my $tt_params = { %{ _get_tt_params( $tables ) }, %{ _get_tt_params( $loops, 'is_a_loop' ) }, %$substitute };
1456
1457     $content = add_tt_filters( $content );
1458     $content = qq|[% USE KohaDates %][% USE Remove_MARC_punctuation %]$content|;
1459
1460     my $output;
1461     $template->process( \$content, $tt_params, \$output ) || croak "ERROR PROCESSING TEMPLATE: " . $template->error();
1462
1463     return $output;
1464 }
1465
1466 sub _get_tt_params {
1467     my ($tables, $is_a_loop) = @_;
1468
1469     my $params;
1470     $is_a_loop ||= 0;
1471
1472     my $config = {
1473         article_requests => {
1474             module   => 'Koha::ArticleRequests',
1475             singular => 'article_request',
1476             plural   => 'article_requests',
1477             pk       => 'id',
1478           },
1479         biblio => {
1480             module   => 'Koha::Biblios',
1481             singular => 'biblio',
1482             plural   => 'biblios',
1483             pk       => 'biblionumber',
1484         },
1485         biblioitems => {
1486             module   => 'Koha::Biblioitems',
1487             singular => 'biblioitem',
1488             plural   => 'biblioitems',
1489             pk       => 'biblioitemnumber',
1490         },
1491         borrowers => {
1492             module   => 'Koha::Patrons',
1493             singular => 'borrower',
1494             plural   => 'borrowers',
1495             pk       => 'borrowernumber',
1496         },
1497         branches => {
1498             module   => 'Koha::Libraries',
1499             singular => 'branch',
1500             plural   => 'branches',
1501             pk       => 'branchcode',
1502         },
1503         items => {
1504             module   => 'Koha::Items',
1505             singular => 'item',
1506             plural   => 'items',
1507             pk       => 'itemnumber',
1508         },
1509         opac_news => {
1510             module   => 'Koha::News',
1511             singular => 'news',
1512             plural   => 'news',
1513             pk       => 'idnew',
1514         },
1515         aqorders => {
1516             module   => 'Koha::Acquisition::Orders',
1517             singular => 'order',
1518             plural   => 'orders',
1519             pk       => 'ordernumber',
1520         },
1521         reserves => {
1522             module   => 'Koha::Holds',
1523             singular => 'hold',
1524             plural   => 'holds',
1525             fk       => [ 'borrowernumber', 'biblionumber' ],
1526         },
1527         serial => {
1528             module   => 'Koha::Serials',
1529             singular => 'serial',
1530             plural   => 'serials',
1531             pk       => 'serialid',
1532         },
1533         subscription => {
1534             module   => 'Koha::Subscriptions',
1535             singular => 'subscription',
1536             plural   => 'subscriptions',
1537             pk       => 'subscriptionid',
1538         },
1539         suggestions => {
1540             module   => 'Koha::Suggestions',
1541             singular => 'suggestion',
1542             plural   => 'suggestions',
1543             pk       => 'suggestionid',
1544         },
1545         issues => {
1546             module   => 'Koha::Checkouts',
1547             singular => 'checkout',
1548             plural   => 'checkouts',
1549             fk       => 'itemnumber',
1550         },
1551         old_issues => {
1552             module   => 'Koha::Old::Checkouts',
1553             singular => 'old_checkout',
1554             plural   => 'old_checkouts',
1555             fk       => 'itemnumber',
1556         },
1557         overdues => {
1558             module   => 'Koha::Checkouts',
1559             singular => 'overdue',
1560             plural   => 'overdues',
1561             fk       => 'itemnumber',
1562         },
1563         borrower_modifications => {
1564             module   => 'Koha::Patron::Modifications',
1565             singular => 'patron_modification',
1566             plural   => 'patron_modifications',
1567             fk       => 'verification_token',
1568         },
1569     };
1570
1571     foreach my $table ( keys %$tables ) {
1572         next unless $config->{$table};
1573
1574         my $ref = ref( $tables->{$table} ) || q{};
1575         my $module = $config->{$table}->{module};
1576
1577         if ( can_load( modules => { $module => undef } ) ) {
1578             my $pk = $config->{$table}->{pk};
1579             my $fk = $config->{$table}->{fk};
1580
1581             if ( $is_a_loop ) {
1582                 my $values = $tables->{$table} || [];
1583                 unless ( ref( $values ) eq 'ARRAY' ) {
1584                     croak "ERROR processing table $table. Wrong API call.";
1585                 }
1586                 my $key = $pk ? $pk : $fk;
1587                 # $key does not come from user input
1588                 my $objects = $module->search(
1589                     { $key => $values },
1590                     {
1591                             # We want to retrieve the data in the same order
1592                             # FIXME MySQLism
1593                             # field is a MySQLism, but they are no other way to do it
1594                             # To be generic we could do it in perl, but we will need to fetch
1595                             # all the data then order them
1596                         @$values ? ( order_by => \[ "field($key, " . join( ', ', @$values ) . ")" ] ) : ()
1597                     }
1598                 );
1599                 $params->{ $config->{$table}->{plural} } = $objects;
1600             }
1601             elsif ( $ref eq q{} || $ref eq 'HASH' ) {
1602                 my $id = ref $ref eq 'HASH' ? $tables->{$table}->{$pk} : $tables->{$table};
1603                 my $object;
1604                 if ( $fk ) { # Using a foreign key for lookup
1605                     if ( ref( $fk ) eq 'ARRAY' ) { # Foreign key is multi-column
1606                         my $search;
1607                         foreach my $key ( @$fk ) {
1608                             $search->{$key} = $id->{$key};
1609                         }
1610                         $object = $module->search( $search )->last();
1611                     } else { # Foreign key is single column
1612                         $object = $module->search( { $fk => $id } )->last();
1613                     }
1614                 } else { # using the table's primary key for lookup
1615                     $object = $module->find($id);
1616                 }
1617                 $params->{ $config->{$table}->{singular} } = $object;
1618             }
1619             else {    # $ref eq 'ARRAY'
1620                 my $object;
1621                 if ( @{ $tables->{$table} } == 1 ) {    # Param is a single key
1622                     $object = $module->search( { $pk => $tables->{$table} } )->last();
1623                 }
1624                 else {                                  # Params are mutliple foreign keys
1625                     croak "Multiple foreign keys (table $table) should be passed using an hashref";
1626                 }
1627                 $params->{ $config->{$table}->{singular} } = $object;
1628             }
1629         }
1630         else {
1631             croak "ERROR LOADING MODULE $module: $Module::Load::Conditional::ERROR";
1632         }
1633     }
1634
1635     $params->{today} = output_pref({ dt => dt_from_string, dateformat => 'iso' });
1636
1637     return $params;
1638 }
1639
1640 =head3 add_tt_filters
1641
1642 $content = add_tt_filters( $content );
1643
1644 Add TT filters to some specific fields if needed.
1645
1646 For now we only add the Remove_MARC_punctuation TT filter to biblio and biblioitem fields
1647
1648 =cut
1649
1650 sub add_tt_filters {
1651     my ( $content ) = @_;
1652     $content =~ s|\[%\s*biblio\.(.*?)\s*%\]|[% biblio.$1 \| \$Remove_MARC_punctuation %]|gxms;
1653     $content =~ s|\[%\s*biblioitem\.(.*?)\s*%\]|[% biblioitem.$1 \| \$Remove_MARC_punctuation %]|gxms;
1654     return $content;
1655 }
1656
1657 =head2 get_item_content
1658
1659     my $item = Koha::Items->find(...)->unblessed;
1660     my @item_content_fields = qw( date_due title barcode author itemnumber );
1661     my $item_content = C4::Letters::get_item_content({
1662                              item => $item,
1663                              item_content_fields => \@item_content_fields
1664                        });
1665
1666 This function generates a tab-separated list of values for the passed item. Dates
1667 are formatted following the current setup.
1668
1669 =cut
1670
1671 sub get_item_content {
1672     my ( $params ) = @_;
1673     my $item = $params->{item};
1674     my $dateonly = $params->{dateonly} || 0;
1675     my $item_content_fields = $params->{item_content_fields} || [];
1676
1677     return unless $item;
1678
1679     my @item_info = map {
1680         $_ =~ /^date|date$/
1681           ? eval {
1682             output_pref(
1683                 { dt => dt_from_string( $item->{$_} ), dateonly => $dateonly } );
1684           }
1685           : $item->{$_}
1686           || ''
1687     } @$item_content_fields;
1688     return join( "\t", @item_info ) . "\n";
1689 }
1690
1691 1;
1692 __END__