Bug 9016: (follow-up) various fixes
[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 under the
8 # terms of the GNU General Public License as published by the Free Software
9 # Foundation; either version 2 of the License, or (at your option) any later
10 # version.
11 #
12 # Koha is distributed in the hope that it will be useful, but WITHOUT ANY
13 # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR
14 # A PARTICULAR PURPOSE.  See the GNU General Public License for more details.
15 #
16 # You should have received a copy of the GNU General Public License along
17 # with Koha; if not, write to the Free Software Foundation, Inc.,
18 # 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
19
20 use strict;
21 use warnings;
22
23 use MIME::Lite;
24 use Mail::Sendmail;
25
26 use C4::Koha qw(GetAuthorisedValueByCode);
27 use C4::Members;
28 use C4::Members::Attributes qw(GetBorrowerAttributes);
29 use C4::Branch;
30 use C4::Log;
31 use C4::SMS;
32 use C4::Debug;
33 use Koha::DateUtils;
34 use Date::Calc qw( Add_Delta_Days );
35 use Encode;
36 use Carp;
37
38 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
39
40 BEGIN {
41     require Exporter;
42     # set the version for version checking
43     $VERSION = 3.07.00.049;
44     @ISA = qw(Exporter);
45     @EXPORT = qw(
46         &GetLetters &GetPreparedLetter &GetWrappedLetter &addalert &getalert &delalert &findrelatedto &SendAlerts &GetPrintMessages &GetMessageTransportTypes
47     );
48 }
49
50 =head1 NAME
51
52 C4::Letters - Give functions for Letters management
53
54 =head1 SYNOPSIS
55
56   use C4::Letters;
57
58 =head1 DESCRIPTION
59
60   "Letters" is the tool used in Koha to manage informations sent to the patrons and/or the library. This include some cron jobs like
61   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)
62
63   Letters are managed through "alerts" sent by Koha on some events. All "alert" related functions are in this module too.
64
65 =head2 GetLetters([$category])
66
67   $letters = &GetLetters($category);
68   returns informations about letters.
69   if needed, $category filters for letters given category
70   Create a letter selector with the following code
71
72 =head3 in PERL SCRIPT
73
74 my $letters = GetLetters($cat);
75 my @letterloop;
76 foreach my $thisletter (keys %$letters) {
77     my $selected = 1 if $thisletter eq $letter;
78     my %row =(
79         value => $thisletter,
80         selected => $selected,
81         lettername => $letters->{$thisletter},
82     );
83     push @letterloop, \%row;
84 }
85 $template->param(LETTERLOOP => \@letterloop);
86
87 =head3 in TEMPLATE
88
89     <select name="letter">
90         <option value="">Default</option>
91     <!-- TMPL_LOOP name="LETTERLOOP" -->
92         <option value="<!-- TMPL_VAR name="value" -->" <!-- TMPL_IF name="selected" -->selected<!-- /TMPL_IF -->><!-- TMPL_VAR name="lettername" --></option>
93     <!-- /TMPL_LOOP -->
94     </select>
95
96 =cut
97
98 sub GetLetters {
99
100     # returns a reference to a hash of references to ALL letters...
101     my ( $cat, $message_transport_type ) = @_;
102     $message_transport_type ||= 'email';
103     my %letters;
104     my $dbh = C4::Context->dbh;
105     my $sth;
106     my $query = q{
107         SELECT * FROM letter WHERE
108     };
109     $query .= q{ module = ? AND } if defined $cat;
110     $query .= q{ message_transport_type = ? ORDER BY name};
111     $sth = $dbh->prepare($query);
112     $sth->execute((defined $cat ? $cat : ()), $message_transport_type);
113
114     while ( my $letter = $sth->fetchrow_hashref ) {
115         $letters{ $letter->{'code'} } = $letter->{'name'};
116     }
117     return \%letters;
118 }
119
120 # FIXME: using our here means that a Plack server will need to be
121 #        restarted fairly regularly when working with this routine.
122 #        A better option would be to use Koha::Cache and use a cache
123 #        that actually works in a persistent environment, but as a
124 #        short-term fix, our will work.
125 our %letter;
126 sub getletter {
127     my ( $module, $code, $branchcode, $message_transport_type ) = @_;
128     $message_transport_type ||= 'email';
129
130
131     if ( C4::Context->preference('IndependentBranches')
132             and $branchcode
133             and C4::Context->userenv ) {
134
135         $branchcode = C4::Context->userenv->{'branch'};
136     }
137     $branchcode //= '';
138
139     if ( my $l = $letter{$module}{$code}{$branchcode}{$message_transport_type} ) {
140         return { %$l }; # deep copy
141     }
142
143     my $dbh = C4::Context->dbh;
144     my $sth = $dbh->prepare(q{
145         SELECT *
146         FROM letter
147         WHERE module=? AND code=? AND (branchcode = ? OR branchcode = '') AND message_transport_type = ?
148         ORDER BY branchcode DESC LIMIT 1
149     });
150     $sth->execute( $module, $code, $branchcode, $message_transport_type );
151     my $line = $sth->fetchrow_hashref
152       or return;
153     $line->{'content-type'} = 'text/html; charset="UTF-8"' if $line->{is_html};
154     $letter{$module}{$code}{$branchcode}{$message_transport_type} = $line;
155     return { %$line };
156 }
157
158 =head2 addalert ($borrowernumber, $type, $externalid)
159
160     parameters : 
161     - $borrowernumber : the number of the borrower subscribing to the alert
162     - $type : the type of alert.
163     - $externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid.
164     
165     create an alert and return the alertid (primary key)
166
167 =cut
168
169 sub addalert {
170     my ( $borrowernumber, $type, $externalid ) = @_;
171     my $dbh = C4::Context->dbh;
172     my $sth =
173       $dbh->prepare(
174         "insert into alert (borrowernumber, type, externalid) values (?,?,?)");
175     $sth->execute( $borrowernumber, $type, $externalid );
176
177     # get the alert number newly created and return it
178     my $alertid = $dbh->{'mysql_insertid'};
179     return $alertid;
180 }
181
182 =head2 delalert ($alertid)
183
184     parameters :
185     - alertid : the alert id
186     deletes the alert
187
188 =cut
189
190 sub delalert {
191     my $alertid = shift or die "delalert() called without valid argument (alertid)";    # it's gonna die anyway.
192     $debug and warn "delalert: deleting alertid $alertid";
193     my $sth = C4::Context->dbh->prepare("delete from alert where alertid=?");
194     $sth->execute($alertid);
195 }
196
197 =head2 getalert ([$borrowernumber], [$type], [$externalid])
198
199     parameters :
200     - $borrowernumber : the number of the borrower subscribing to the alert
201     - $type : the type of alert.
202     - $externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid.
203     all parameters NON mandatory. If a parameter is omitted, the query is done without the corresponding parameter. For example, without $externalid, returns all alerts for a borrower on a topic.
204
205 =cut
206
207 sub getalert {
208     my ( $borrowernumber, $type, $externalid ) = @_;
209     my $dbh   = C4::Context->dbh;
210     my $query = "SELECT a.*, b.branchcode FROM alert a JOIN borrowers b USING(borrowernumber) WHERE";
211     my @bind;
212     if ($borrowernumber and $borrowernumber =~ /^\d+$/) {
213         $query .= " borrowernumber=? AND ";
214         push @bind, $borrowernumber;
215     }
216     if ($type) {
217         $query .= " type=? AND ";
218         push @bind, $type;
219     }
220     if ($externalid) {
221         $query .= " externalid=? AND ";
222         push @bind, $externalid;
223     }
224     $query =~ s/ AND $//;
225     my $sth = $dbh->prepare($query);
226     $sth->execute(@bind);
227     return $sth->fetchall_arrayref({});
228 }
229
230 =head2 findrelatedto($type, $externalid)
231
232         parameters :
233         - $type : the type of alert
234         - $externalid : the id of the "object" to query
235         
236         In the table alert, a "id" is stored in the externalid field. This "id" is related to another table, depending on the type of the alert.
237         When type=issue, the id is related to a subscriptionid and this sub returns the name of the biblio.
238
239 =cut
240     
241 # outmoded POD:
242 # When type=virtual, the id is related to a virtual shelf and this sub returns the name of the sub
243
244 sub findrelatedto {
245     my $type       = shift or return;
246     my $externalid = shift or return;
247     my $q = ($type eq 'issue'   ) ?
248 "select title as result from subscription left join biblio on subscription.biblionumber=biblio.biblionumber where subscriptionid=?" :
249             ($type eq 'borrower') ?
250 "select concat(firstname,' ',surname) from borrowers where borrowernumber=?" : undef;
251     unless ($q) {
252         warn "findrelatedto(): Illegal type '$type'";
253         return;
254     }
255     my $sth = C4::Context->dbh->prepare($q);
256     $sth->execute($externalid);
257     my ($result) = $sth->fetchrow;
258     return $result;
259 }
260
261 =head2 SendAlerts
262
263     parameters :
264     - $type : the type of alert
265     - $externalid : the id of the "object" to query
266     - $letter_code : the letter to send.
267
268     send an alert to all borrowers having put an alert on a given subject.
269
270 =cut
271
272 sub SendAlerts {
273     my ( $type, $externalid, $letter_code ) = @_;
274     my $dbh = C4::Context->dbh;
275     if ( $type eq 'issue' ) {
276
277         # prepare the letter...
278         # search the biblionumber
279         my $sth =
280           $dbh->prepare(
281             "SELECT biblionumber FROM subscription WHERE subscriptionid=?");
282         $sth->execute($externalid);
283         my ($biblionumber) = $sth->fetchrow
284           or warn( "No subscription for '$externalid'" ),
285              return;
286
287         my %letter;
288         # find the list of borrowers to alert
289         my $alerts = getalert( '', 'issue', $externalid );
290         foreach (@$alerts) {
291
292             my $borinfo = C4::Members::GetMember('borrowernumber' => $_->{'borrowernumber'});
293             my $email = $borinfo->{email} or next;
294
295             #           warn "sending issues...";
296             my $userenv = C4::Context->userenv;
297             my $branchdetails = GetBranchDetail($_->{'branchcode'});
298             my $letter = GetPreparedLetter (
299                 module => 'serial',
300                 letter_code => $letter_code,
301                 branchcode => $userenv->{branch},
302                 tables => {
303                     'branches'    => $_->{branchcode},
304                     'biblio'      => $biblionumber,
305                     'biblioitems' => $biblionumber,
306                     'borrowers'   => $borinfo,
307                 },
308                 want_librarian => 1,
309             ) or return;
310
311             # ... then send mail
312             my %mail = (
313                 To      => $email,
314                 From    => $branchdetails->{'branchemail'} || C4::Context->preference("KohaAdminEmailAddress"),
315                 Subject => Encode::encode( "utf8", "" . $letter->{title} ),
316                 Message => Encode::encode( "utf8", "" . $letter->{content} ),
317                 'Content-Type' => 'text/plain; charset="utf8"',
318                 );
319             sendmail(%mail) or carp $Mail::Sendmail::error;
320         }
321     }
322     elsif ( $type eq 'claimacquisition' or $type eq 'claimissues' ) {
323
324         # prepare the letter...
325         # search the biblionumber
326         my $strsth =  $type eq 'claimacquisition'
327             ? qq{
328             SELECT aqorders.*,aqbasket.*,biblio.*,biblioitems.*,aqbooksellers.*,
329             aqbooksellers.id AS booksellerid
330             FROM aqorders
331             LEFT JOIN aqbasket ON aqbasket.basketno=aqorders.basketno
332             LEFT JOIN biblio ON aqorders.biblionumber=biblio.biblionumber
333             LEFT JOIN biblioitems ON aqorders.biblionumber=biblioitems.biblionumber
334             LEFT JOIN aqbooksellers ON aqbasket.booksellerid=aqbooksellers.id
335             WHERE aqorders.ordernumber IN (
336             }
337             : qq{
338             SELECT serial.*,subscription.*, biblio.*, aqbooksellers.*,
339             aqbooksellers.id AS booksellerid
340             FROM serial
341             LEFT JOIN subscription ON serial.subscriptionid=subscription.subscriptionid
342             LEFT JOIN biblio ON serial.biblionumber=biblio.biblionumber
343             LEFT JOIN aqbooksellers ON subscription.aqbooksellerid=aqbooksellers.id
344             WHERE serial.serialid IN (
345             };
346         $strsth .= join( ",", @$externalid ) . ")";
347         my $sthorders = $dbh->prepare($strsth);
348         $sthorders->execute;
349         my $dataorders = $sthorders->fetchall_arrayref( {} );
350
351         my $sthbookseller =
352           $dbh->prepare("select * from aqbooksellers where id=?");
353         $sthbookseller->execute( $dataorders->[0]->{booksellerid} );
354         my $databookseller = $sthbookseller->fetchrow_hashref;
355
356         my @email;
357         push @email, $databookseller->{bookselleremail} if $databookseller->{bookselleremail};
358         push @email, $databookseller->{contemail}       if $databookseller->{contemail};
359         unless (@email) {
360             warn "Bookseller $dataorders->[0]->{booksellerid} without emails";
361             return { error => "no_email" };
362         }
363
364         my $userenv = C4::Context->userenv;
365         my $letter = GetPreparedLetter (
366             module => $type,
367             letter_code => $letter_code,
368             branchcode => $userenv->{branch},
369             tables => {
370                 'branches'    => $userenv->{branch},
371                 'aqbooksellers' => $databookseller,
372             },
373             repeat => $dataorders,
374             want_librarian => 1,
375         ) or return;
376
377         # ... then send mail
378         my %mail = (
379             To => join( ',', @email),
380             From           => $userenv->{emailaddress},
381             Subject        => Encode::encode( "utf8", "" . $letter->{title} ),
382             Message        => Encode::encode( "utf8", "" . $letter->{content} ),
383             'Content-Type' => 'text/plain; charset="utf8"',
384         );
385         sendmail(%mail) or carp $Mail::Sendmail::error;
386
387         logaction(
388             "ACQUISITION",
389             $type eq 'claimissues' ? "CLAIM ISSUE" : "ACQUISITION CLAIM",
390             undef,
391             "To="
392                 . $databookseller->{contemail}
393                 . " Title="
394                 . $letter->{title}
395                 . " Content="
396                 . $letter->{content}
397         ) if C4::Context->preference("LetterLog");
398     }
399    # send an "account details" notice to a newly created user
400     elsif ( $type eq 'members' ) {
401         my $branchdetails = GetBranchDetail($externalid->{'branchcode'});
402         my $letter = GetPreparedLetter (
403             module => 'members',
404             letter_code => $letter_code,
405             branchcode => $externalid->{'branchcode'},
406             tables => {
407                 'branches'    => $branchdetails,
408                 'borrowers' => $externalid->{'borrowernumber'},
409             },
410             substitute => { 'borrowers.password' => $externalid->{'password'} },
411             want_librarian => 1,
412         ) or return;
413
414         return { error => "no_email" } unless $externalid->{'emailaddr'};
415         my %mail = (
416                 To      =>     $externalid->{'emailaddr'},
417                 From    =>  $branchdetails->{'branchemail'} || C4::Context->preference("KohaAdminEmailAddress"),
418                 Subject => Encode::encode( "utf8", $letter->{'title'} ),
419                 Message => Encode::encode( "utf8", $letter->{'content'} ),
420                 'Content-Type' => 'text/plain; charset="utf8"',
421         );
422         sendmail(%mail) or carp $Mail::Sendmail::error;
423     }
424 }
425
426 =head2 GetPreparedLetter( %params )
427
428     %params hash:
429       module => letter module, mandatory
430       letter_code => letter code, mandatory
431       branchcode => for letter selection, if missing default system letter taken
432       tables => a hashref with table names as keys. Values are either:
433         - a scalar - primary key value
434         - an arrayref - primary key values
435         - a hashref - full record
436       substitute => custom substitution key/value pairs
437       repeat => records to be substituted on consecutive lines:
438         - an arrayref - tries to guess what needs substituting by
439           taking remaining << >> tokensr; not recommended
440         - a hashref token => @tables - replaces <token> << >> << >> </token>
441           subtemplate for each @tables row; table is a hashref as above
442       want_librarian => boolean,  if set to true triggers librarian details
443         substitution from the userenv
444     Return value:
445       letter fields hashref (title & content useful)
446
447 =cut
448
449 sub GetPreparedLetter {
450     my %params = @_;
451
452     my $module      = $params{module} or croak "No module";
453     my $letter_code = $params{letter_code} or croak "No letter_code";
454     my $branchcode  = $params{branchcode} || '';
455
456     my $letter = getletter( $module, $letter_code, $branchcode, $params{message_transport_type} )
457         or warn( "No $module $letter_code letter"),
458             return;
459
460     my $tables = $params{tables};
461     my $substitute = $params{substitute};
462     my $repeat = $params{repeat};
463     $tables || $substitute || $repeat
464       or carp( "ERROR: nothing to substitute - both 'tables' and 'substitute' are empty" ),
465          return;
466     my $want_librarian = $params{want_librarian};
467
468     if ($substitute) {
469         while ( my ($token, $val) = each %$substitute ) {
470             $letter->{title} =~ s/<<$token>>/$val/g;
471             $letter->{content} =~ s/<<$token>>/$val/g;
472        }
473     }
474
475     my $OPACBaseURL = C4::Context->preference('OPACBaseURL');
476     $letter->{content} =~ s/<<OPACBaseURL>>/$OPACBaseURL/go;
477
478     if ($want_librarian) {
479         # parsing librarian name
480         my $userenv = C4::Context->userenv;
481         $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/go;
482         $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/go;
483         $letter->{content} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/go;
484     }
485
486     my ($repeat_no_enclosing_tags, $repeat_enclosing_tags);
487
488     if ($repeat) {
489         if (ref ($repeat) eq 'ARRAY' ) {
490             $repeat_no_enclosing_tags = $repeat;
491         } else {
492             $repeat_enclosing_tags = $repeat;
493         }
494     }
495
496     if ($repeat_enclosing_tags) {
497         while ( my ($tag, $tag_tables) = each %$repeat_enclosing_tags ) {
498             if ( $letter->{content} =~ m!<$tag>(.*)</$tag>!s ) {
499                 my $subcontent = $1;
500                 my @lines = map {
501                     my %subletter = ( title => '', content => $subcontent );
502                     _substitute_tables( \%subletter, $_ );
503                     $subletter{content};
504                 } @$tag_tables;
505                 $letter->{content} =~ s!<$tag>.*</$tag>!join( "\n", @lines )!se;
506             }
507         }
508     }
509
510     if ($tables) {
511         _substitute_tables( $letter, $tables );
512     }
513
514     if ($repeat_no_enclosing_tags) {
515         if ( $letter->{content} =~ m/[^\n]*<<.*>>[^\n]*/so ) {
516             my $line = $&;
517             my $i = 1;
518             my @lines = map {
519                 my $c = $line;
520                 $c =~ s/<<count>>/$i/go;
521                 foreach my $field ( keys %{$_} ) {
522                     $c =~ s/(<<[^\.]+.$field>>)/$_->{$field}/;
523                 }
524                 $i++;
525                 $c;
526             } @$repeat_no_enclosing_tags;
527
528             my $replaceby = join( "\n", @lines );
529             $letter->{content} =~ s/\Q$line\E/$replaceby/s;
530         }
531     }
532
533     $letter->{content} =~ s/<<\S*>>//go; #remove any stragglers
534 #   $letter->{content} =~ s/<<[^>]*>>//go;
535
536     return $letter;
537 }
538
539 sub _substitute_tables {
540     my ( $letter, $tables ) = @_;
541     while ( my ($table, $param) = each %$tables ) {
542         next unless $param;
543
544         my $ref = ref $param;
545
546         my $values;
547         if ($ref && $ref eq 'HASH') {
548             $values = $param;
549         }
550         else {
551             my @pk;
552             my $sth = _parseletter_sth($table);
553             unless ($sth) {
554                 warn "_parseletter_sth('$table') failed to return a valid sth.  No substitution will be done for that table.";
555                 return;
556             }
557             $sth->execute( $ref ? @$param : $param );
558
559             $values = $sth->fetchrow_hashref;
560             $sth->finish();
561         }
562
563         _parseletter ( $letter, $table, $values );
564     }
565 }
566
567 sub _parseletter_sth {
568     my $table = shift;
569     my $sth;
570     unless ($table) {
571         carp "ERROR: _parseletter_sth() called without argument (table)";
572         return;
573     }
574     # NOTE: we used to check whether we had a statement handle cached in
575     #       a %handles module-level variable. This was a dumb move and
576     #       broke things for the rest of us. prepare_cached is a better
577     #       way to cache statement handles anyway.
578     my $query = 
579     ($table eq 'biblio'       ) ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
580     ($table eq 'biblioitems'  ) ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
581     ($table eq 'items'        ) ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
582     ($table eq 'issues'       ) ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
583     ($table eq 'old_issues'   ) ? "SELECT * FROM $table WHERE     itemnumber = ? ORDER BY timestamp DESC LIMIT 1"  :
584     ($table eq 'reserves'     ) ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?"             :
585     ($table eq 'borrowers'    ) ? "SELECT * FROM $table WHERE borrowernumber = ?"                                  :
586     ($table eq 'branches'     ) ? "SELECT * FROM $table WHERE     branchcode = ?"                                  :
587     ($table eq 'suggestions'  ) ? "SELECT * FROM $table WHERE   suggestionid = ?"                                  :
588     ($table eq 'aqbooksellers') ? "SELECT * FROM $table WHERE             id = ?"                                  :
589     ($table eq 'aqorders'     ) ? "SELECT * FROM $table WHERE    ordernumber = ?"                                  :
590     ($table eq 'opac_news'    ) ? "SELECT * FROM $table WHERE          idnew = ?"                                  :
591     ($table eq 'borrower_modifications') ? "SELECT * FROM $table WHERE borrowernumber = ? OR verification_token =?":
592     undef ;
593     unless ($query) {
594         warn "ERROR: No _parseletter_sth query for table '$table'";
595         return;     # nothing to get
596     }
597     unless ($sth = C4::Context->dbh->prepare_cached($query)) {
598         warn "ERROR: Failed to prepare query: '$query'";
599         return;
600     }
601     return $sth;    # now cache is populated for that $table
602 }
603
604 =head2 _parseletter($letter, $table, $values)
605
606     parameters :
607     - $letter : a hash to letter fields (title & content useful)
608     - $table : the Koha table to parse.
609     - $values : table record hashref
610     parse all fields from a table, and replace values in title & content with the appropriate value
611     (not exported sub, used only internally)
612
613 =cut
614
615 sub _parseletter {
616     my ( $letter, $table, $values ) = @_;
617
618     if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
619         my @waitingdate = split /-/, $values->{'waitingdate'};
620
621         $values->{'expirationdate'} = '';
622         if( C4::Context->preference('ExpireReservesMaxPickUpDelay') &&
623         C4::Context->preference('ReservesMaxPickUpDelay') ) {
624             my $dt = dt_from_string();
625             $dt->add( days => C4::Context->preference('ReservesMaxPickUpDelay') );
626             $values->{'expirationdate'} = output_pref({ dt => $dt, dateonly => 1 });
627         }
628
629         $values->{'waitingdate'} = output_pref({ dt => dt_from_string( $values->{'waitingdate'} ), dateonly => 1 });
630
631     }
632
633     if ($letter->{content} && $letter->{content} =~ /<<today>>/) {
634         my $todaysdate = output_pref( DateTime->now() );
635         $letter->{content} =~ s/<<today>>/$todaysdate/go;
636     }
637
638     while ( my ($field, $val) = each %$values ) {
639         my $replacetablefield = "<<$table.$field>>";
640         my $replacefield = "<<$field>>";
641         $val =~ s/\p{P}$// if $val && $table=~/biblio/;
642             #BZ 9886: Assuming that we want to eliminate ISBD punctuation here
643             #Therefore adding the test on biblio. This includes biblioitems,
644             #but excludes items. Removed unneeded global and lookahead.
645
646         $val = GetAuthorisedValueByCode ('ROADTYPE', $val, 0) if $table=~/^borrowers$/ && $field=~/^streettype$/;
647         my $replacedby   = defined ($val) ? $val : '';
648         ($letter->{title}  ) and do {
649             $letter->{title}   =~ s/$replacetablefield/$replacedby/g;
650             $letter->{title}   =~ s/$replacefield/$replacedby/g;
651         };
652         ($letter->{content}) and do {
653             $letter->{content} =~ s/$replacetablefield/$replacedby/g;
654             $letter->{content} =~ s/$replacefield/$replacedby/g;
655         };
656     }
657
658     if ($table eq 'borrowers' && $letter->{content}) {
659         if ( my $attributes = GetBorrowerAttributes($values->{borrowernumber}) ) {
660             my %attr;
661             foreach (@$attributes) {
662                 my $code = $_->{code};
663                 my $val  = $_->{value_description} || $_->{value};
664                 $val =~ s/\p{P}(?=$)//g if $val;
665                 next unless $val gt '';
666                 $attr{$code} ||= [];
667                 push @{ $attr{$code} }, $val;
668             }
669             while ( my ($code, $val_ar) = each %attr ) {
670                 my $replacefield = "<<borrower-attribute:$code>>";
671                 my $replacedby   = join ',', @$val_ar;
672                 $letter->{content} =~ s/$replacefield/$replacedby/g;
673             }
674         }
675     }
676     return $letter;
677 }
678
679 =head2 EnqueueLetter
680
681   my $success = EnqueueLetter( { letter => $letter, 
682         borrowernumber => '12', message_transport_type => 'email' } )
683
684 places a letter in the message_queue database table, which will
685 eventually get processed (sent) by the process_message_queue.pl
686 cronjob when it calls SendQueuedMessages.
687
688 return message_id on success
689
690 =cut
691
692 sub EnqueueLetter {
693     my $params = shift or return;
694
695     return unless exists $params->{'letter'};
696 #   return unless exists $params->{'borrowernumber'};
697     return unless exists $params->{'message_transport_type'};
698
699     my $content = $params->{letter}->{content};
700     $content =~ s/\s+//g if(defined $content);
701     if ( not defined $content or $content eq '' ) {
702         warn "Trying to add an empty message to the message queue" if $debug;
703         return;
704     }
705
706     # If we have any attachments we should encode then into the body.
707     if ( $params->{'attachments'} ) {
708         $params->{'letter'} = _add_attachments(
709             {   letter      => $params->{'letter'},
710                 attachments => $params->{'attachments'},
711                 message     => MIME::Lite->new( Type => 'multipart/mixed' ),
712             }
713         );
714     }
715
716     my $dbh       = C4::Context->dbh();
717     my $statement = << 'ENDSQL';
718 INSERT INTO message_queue
719 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type )
720 VALUES
721 ( ?,              ?,       ?,       ?,        ?,           ?,                      ?,      NOW(),       ?,          ?,            ? )
722 ENDSQL
723
724     my $sth    = $dbh->prepare($statement);
725     my $result = $sth->execute(
726         $params->{'borrowernumber'},              # borrowernumber
727         $params->{'letter'}->{'title'},           # subject
728         $params->{'letter'}->{'content'},         # content
729         $params->{'letter'}->{'metadata'} || '',  # metadata
730         $params->{'letter'}->{'code'}     || '',  # letter_code
731         $params->{'message_transport_type'},      # message_transport_type
732         'pending',                                # status
733         $params->{'to_address'},                  # to_address
734         $params->{'from_address'},                # from_address
735         $params->{'letter'}->{'content-type'},    # content_type
736     );
737     return $dbh->last_insert_id(undef,undef,'message_queue', undef);
738 }
739
740 =head2 SendQueuedMessages ([$hashref]) 
741
742   my $sent = SendQueuedMessages( { verbose => 1 } );
743
744 sends all of the 'pending' items in the message queue.
745
746 returns number of messages sent.
747
748 =cut
749
750 sub SendQueuedMessages {
751     my $params = shift;
752
753     my $unsent_messages = _get_unsent_messages();
754     MESSAGE: foreach my $message ( @$unsent_messages ) {
755         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
756         warn sprintf( 'sending %s message to patron: %s',
757                       $message->{'message_transport_type'},
758                       $message->{'borrowernumber'} || 'Admin' )
759           if $params->{'verbose'} or $debug;
760         # This is just begging for subclassing
761         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
762         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
763             _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
764         }
765         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
766             _send_message_by_sms( $message );
767         }
768     }
769     return scalar( @$unsent_messages );
770 }
771
772 =head2 GetRSSMessages
773
774   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
775
776 returns a listref of all queued RSS messages for a particular person.
777
778 =cut
779
780 sub GetRSSMessages {
781     my $params = shift;
782
783     return unless $params;
784     return unless ref $params;
785     return unless $params->{'borrowernumber'};
786     
787     return _get_unsent_messages( { message_transport_type => 'rss',
788                                    limit                  => $params->{'limit'},
789                                    borrowernumber         => $params->{'borrowernumber'}, } );
790 }
791
792 =head2 GetPrintMessages
793
794   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
795
796 Returns a arrayref of all queued print messages (optionally, for a particular
797 person).
798
799 =cut
800
801 sub GetPrintMessages {
802     my $params = shift || {};
803     
804     return _get_unsent_messages( { message_transport_type => 'print',
805                                    borrowernumber         => $params->{'borrowernumber'},
806                                  } );
807 }
808
809 =head2 GetQueuedMessages ([$hashref])
810
811   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
812
813 fetches messages out of the message queue.
814
815 returns:
816 list of hashes, each has represents a message in the message queue.
817
818 =cut
819
820 sub GetQueuedMessages {
821     my $params = shift;
822
823     my $dbh = C4::Context->dbh();
824     my $statement = << 'ENDSQL';
825 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued
826 FROM message_queue
827 ENDSQL
828
829     my @query_params;
830     my @whereclauses;
831     if ( exists $params->{'borrowernumber'} ) {
832         push @whereclauses, ' borrowernumber = ? ';
833         push @query_params, $params->{'borrowernumber'};
834     }
835
836     if ( @whereclauses ) {
837         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
838     }
839
840     if ( defined $params->{'limit'} ) {
841         $statement .= ' LIMIT ? ';
842         push @query_params, $params->{'limit'};
843     }
844
845     my $sth = $dbh->prepare( $statement );
846     my $result = $sth->execute( @query_params );
847     return $sth->fetchall_arrayref({});
848 }
849
850 =head2 GetMessageTransportTypes
851
852   my @mtt = GetMessageTransportTypes();
853
854   returns an arrayref of transport types
855
856 =cut
857
858 sub GetMessageTransportTypes {
859     my $dbh = C4::Context->dbh();
860     my $mtts = $dbh->selectcol_arrayref("
861         SELECT message_transport_type
862         FROM message_transport_types
863         ORDER BY message_transport_type
864     ");
865     return $mtts;
866 }
867
868 =head2 _add_attachements
869
870 named parameters:
871 letter - the standard letter hashref
872 attachments - listref of attachments. each attachment is a hashref of:
873   type - the mime type, like 'text/plain'
874   content - the actual attachment
875   filename - the name of the attachment.
876 message - a MIME::Lite object to attach these to.
877
878 returns your letter object, with the content updated.
879
880 =cut
881
882 sub _add_attachments {
883     my $params = shift;
884
885     my $letter = $params->{'letter'};
886     my $attachments = $params->{'attachments'};
887     return $letter unless @$attachments;
888     my $message = $params->{'message'};
889
890     # First, we have to put the body in as the first attachment
891     $message->attach(
892         Type => $letter->{'content-type'} || 'TEXT',
893         Data => $letter->{'is_html'}
894             ? _wrap_html($letter->{'content'}, $letter->{'title'})
895             : $letter->{'content'},
896     );
897
898     foreach my $attachment ( @$attachments ) {
899         $message->attach(
900             Type     => $attachment->{'type'},
901             Data     => $attachment->{'content'},
902             Filename => $attachment->{'filename'},
903         );
904     }
905     # we're forcing list context here to get the header, not the count back from grep.
906     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
907     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
908     $letter->{'content'} = $message->body_as_string;
909
910     return $letter;
911
912 }
913
914 sub _get_unsent_messages {
915     my $params = shift;
916
917     my $dbh = C4::Context->dbh();
918     my $statement = << 'ENDSQL';
919 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
920   FROM message_queue mq
921   LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
922  WHERE status = ?
923 ENDSQL
924
925     my @query_params = ('pending');
926     if ( ref $params ) {
927         if ( $params->{'message_transport_type'} ) {
928             $statement .= ' AND message_transport_type = ? ';
929             push @query_params, $params->{'message_transport_type'};
930         }
931         if ( $params->{'borrowernumber'} ) {
932             $statement .= ' AND borrowernumber = ? ';
933             push @query_params, $params->{'borrowernumber'};
934         }
935         if ( $params->{'limit'} ) {
936             $statement .= ' limit ? ';
937             push @query_params, $params->{'limit'};
938         }
939     }
940
941     $debug and warn "_get_unsent_messages SQL: $statement";
942     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
943     my $sth = $dbh->prepare( $statement );
944     my $result = $sth->execute( @query_params );
945     return $sth->fetchall_arrayref({});
946 }
947
948 sub _send_message_by_email {
949     my $message = shift or return;
950     my ($username, $password, $method) = @_;
951
952     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
953     my $to_address = $message->{'to_address'};
954     unless ($to_address) {
955         unless ($member) {
956             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
957             _set_message_status( { message_id => $message->{'message_id'},
958                                    status     => 'failed' } );
959             return;
960         }
961         $to_address = C4::Members::GetNoticeEmailAddress( $message->{'borrowernumber'} );
962         unless ($to_address) {  
963             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
964             # warning too verbose for this more common case?
965             _set_message_status( { message_id => $message->{'message_id'},
966                                    status     => 'failed' } );
967             return;
968         }
969     }
970
971     my $utf8   = decode('MIME-Header', $message->{'subject'} );
972     $message->{subject}= encode('MIME-Header', $utf8);
973     my $subject = encode('utf8', $message->{'subject'});
974     my $content = encode('utf8', $message->{'content'});
975     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
976     my $is_html = $content_type =~ m/html/io;
977
978     my $branch_email = ( $member ) ? GetBranchDetail( $member->{'branchcode'} )->{'branchemail'} : undef;
979
980     my %sendmail_params = (
981         To   => $to_address,
982         From => $message->{'from_address'} || $branch_email || C4::Context->preference('KohaAdminEmailAddress'),
983         Subject => $subject,
984         charset => 'utf8',
985         Message => $is_html ? _wrap_html($content, $subject) : $content,
986         'content-type' => $content_type,
987     );
988     $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
989     if ( my $bcc = C4::Context->preference('OverdueNoticeBcc') ) {
990        $sendmail_params{ Bcc } = $bcc;
991     }
992
993     _update_message_to_address($message->{'message_id'},$to_address) unless $message->{to_address}; #if initial message address was empty, coming here means that a to address was found and queue should be updated
994     if ( sendmail( %sendmail_params ) ) {
995         _set_message_status( { message_id => $message->{'message_id'},
996                 status     => 'sent' } );
997         return 1;
998     } else {
999         _set_message_status( { message_id => $message->{'message_id'},
1000                 status     => 'failed' } );
1001         carp $Mail::Sendmail::error;
1002         return;
1003     }
1004 }
1005
1006 sub _wrap_html {
1007     my ($content, $title) = @_;
1008
1009     my $css = C4::Context->preference("NoticeCSS") || '';
1010     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
1011     return <<EOS;
1012 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1013     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1014 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1015 <head>
1016 <title>$title</title>
1017 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1018 $css
1019 </head>
1020 <body>
1021 $content
1022 </body>
1023 </html>
1024 EOS
1025 }
1026
1027 sub _send_message_by_sms {
1028     my $message = shift or return;
1029     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
1030
1031     unless ( $member->{smsalertnumber} ) {
1032         _set_message_status( { message_id => $message->{'message_id'},
1033                                status     => 'failed' } );
1034         return;
1035     }
1036
1037     my $success = C4::SMS->send_sms( { destination => $member->{'smsalertnumber'},
1038                                        message     => $message->{'content'},
1039                                      } );
1040     _set_message_status( { message_id => $message->{'message_id'},
1041                            status     => ($success ? 'sent' : 'failed') } );
1042     return $success;
1043 }
1044
1045 sub _update_message_to_address {
1046     my ($id, $to)= @_;
1047     my $dbh = C4::Context->dbh();
1048     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1049 }
1050
1051 sub _set_message_status {
1052     my $params = shift or return;
1053
1054     foreach my $required_parameter ( qw( message_id status ) ) {
1055         return unless exists $params->{ $required_parameter };
1056     }
1057
1058     my $dbh = C4::Context->dbh();
1059     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1060     my $sth = $dbh->prepare( $statement );
1061     my $result = $sth->execute( $params->{'status'},
1062                                 $params->{'message_id'} );
1063     return $result;
1064 }
1065
1066
1067 1;
1068 __END__