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