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 strict;
  21 use warnings;
  22
  23 use MIME::Lite;
  24 use Mail::Sendmail;
  25 use Date::Calc qw( Add_Delta_Days );
  26 use Encode;
  27 use Carp;
  28 use Template;
  29 use Module::Load::Conditional qw(can_load);
  30
  31 use C4::Koha qw(GetAuthorisedValueByCode);
  32 use C4::Members;
  33 use C4::Members::Attributes qw(GetBorrowerAttributes);
  34 use C4::Log;
  35 use C4::SMS;
  36 use C4::Debug;
  37 use Koha::DateUtils;
  38 use Koha::SMS::Providers;
  39
  40 use Koha::Email;
  41 use Koha::DateUtils qw( format_sqldatetime dt_from_string );
  42
  43 use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  44
  45 BEGIN {
  46     require Exporter;
  47     @ISA = qw(Exporter);
  48     @EXPORT = qw(
  49         &GetLetters &GetLettersAvailableForALibrary &GetLetterTemplates &DelLetter &GetPreparedLetter &GetWrappedLetter &addalert &getalert &delalert &findrelatedto &SendAlerts &GetPrintMessages &GetMessageTransportTypes
  50     );
  51 }
  52
  53 =head1 NAME
  54
  55 C4::Letters - Give functions for Letters management
  56
  57 =head1 SYNOPSIS
  58
  59   use C4::Letters;
  60
  61 =head1 DESCRIPTION
  62
  63   "Letters" is the tool used in Koha to manage informations sent to the patrons and/or the library. This include some cron jobs like
  64   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)
  65
  66   Letters are managed through "alerts" sent by Koha on some events. All "alert" related functions are in this module too.
  67
  68 =head2 GetLetters([$module])
  69
  70   $letters = &GetLetters($module);
  71   returns informations about letters.
  72   if needed, $module filters for letters given module
  73
  74 =cut
  75
  76 sub GetLetters {
  77     my ($filters) = @_;
  78     my $module    = $filters->{module};
  79     my $code      = $filters->{code};
  80     my $branchcode = $filters->{branchcode};
  81     my $dbh       = C4::Context->dbh;
  82     my $letters   = $dbh->selectall_arrayref(
  83         q|
  84             SELECT module, code, branchcode, name
  85             FROM letter
  86             WHERE 1
  87         |
  88           . ( $module ? q| AND module = ?| : q|| )
  89           . ( $code   ? q| AND code = ?|   : q|| )
  90           . ( defined $branchcode   ? q| AND branchcode = ?|   : q|| )
  91           . q| GROUP BY code ORDER BY name|, { Slice => {} }
  92         , ( $module ? $module : () )
  93         , ( $code ? $code : () )
  94         , ( defined $branchcode ? $branchcode : () )
  95     );
  96
  97     return $letters;
  98 }
  99
 100 =head2 GetLetterTemplates
 101
 102     my $letter_templates = GetLetterTemplates(
 103         {
 104             module => 'circulation',
 105             code => 'my code',
 106             branchcode => 'CPL', # '' for default,
 107         }
 108     );
 109
 110     Return a hashref of letter templates.
 111     The key will be the message transport type.
 112
 113 =cut
 114
 115 sub GetLetterTemplates {
 116     my ( $params ) = @_;
 117
 118     my $module    = $params->{module};
 119     my $code      = $params->{code};
 120     my $branchcode = $params->{branchcode} // '';
 121     my $dbh       = C4::Context->dbh;
 122     my $letters   = $dbh->selectall_hashref(
 123         q|
 124             SELECT module, code, branchcode, name, is_html, title, content, message_transport_type
 125             FROM letter
 126             WHERE module = ?
 127             AND code = ?
 128             and branchcode = ?
 129         |
 130         , 'message_transport_type'
 131         , undef
 132         , $module, $code, $branchcode
 133     );
 134
 135     return $letters;
 136 }
 137
 138 =head2 GetLettersAvailableForALibrary
 139
 140     my $letters = GetLettersAvailableForALibrary(
 141         {
 142             branchcode => 'CPL', # '' for default
 143             module => 'circulation',
 144         }
 145     );
 146
 147     Return an arrayref of letters, sorted by name.
 148     If a specific letter exist for the given branchcode, it will be retrieve.
 149     Otherwise the default letter will be.
 150
 151 =cut
 152
 153 sub GetLettersAvailableForALibrary {
 154     my ($filters)  = @_;
 155     my $branchcode = $filters->{branchcode};
 156     my $module     = $filters->{module};
 157
 158     croak "module should be provided" unless $module;
 159
 160     my $dbh             = C4::Context->dbh;
 161     my $default_letters = $dbh->selectall_arrayref(
 162         q|
 163             SELECT module, code, branchcode, name
 164             FROM letter
 165             WHERE 1
 166         |
 167           . q| AND branchcode = ''|
 168           . ( $module ? q| AND module = ?| : q|| )
 169           . q| ORDER BY name|, { Slice => {} }
 170         , ( $module ? $module : () )
 171     );
 172
 173     my $specific_letters;
 174     if ($branchcode) {
 175         $specific_letters = $dbh->selectall_arrayref(
 176             q|
 177                 SELECT module, code, branchcode, name
 178                 FROM letter
 179                 WHERE 1
 180             |
 181               . q| AND branchcode = ?|
 182               . ( $module ? q| AND module = ?| : q|| )
 183               . q| ORDER BY name|, { Slice => {} }
 184             , $branchcode
 185             , ( $module ? $module : () )
 186         );
 187     }
 188
 189     my %letters;
 190     for my $l (@$default_letters) {
 191         $letters{ $l->{code} } = $l;
 192     }
 193     for my $l (@$specific_letters) {
 194         # Overwrite the default letter with the specific one.
 195         $letters{ $l->{code} } = $l;
 196     }
 197
 198     return [ map { $letters{$_} }
 199           sort { $letters{$a}->{name} cmp $letters{$b}->{name} }
 200           keys %letters ];
 201
 202 }
 203
 204 sub getletter {
 205     my ( $module, $code, $branchcode, $message_transport_type ) = @_;
 206     $message_transport_type //= '%';
 207
 208     if ( C4::Context->preference('IndependentBranches')
 209             and $branchcode
 210             and C4::Context->userenv ) {
 211
 212         $branchcode = C4::Context->userenv->{'branch'};
 213     }
 214     $branchcode //= '';
 215
 216     my $dbh = C4::Context->dbh;
 217     my $sth = $dbh->prepare(q{
 218         SELECT *
 219         FROM letter
 220         WHERE module=? AND code=? AND (branchcode = ? OR branchcode = '')
 221         AND message_transport_type LIKE ?
 222         ORDER BY branchcode DESC LIMIT 1
 223     });
 224     $sth->execute( $module, $code, $branchcode, $message_transport_type );
 225     my $line = $sth->fetchrow_hashref
 226       or return;
 227     $line->{'content-type'} = 'text/html; charset="UTF-8"' if $line->{is_html};
 228     return { %$line };
 229 }
 230
 231
 232 =head2 DelLetter
 233
 234     DelLetter(
 235         {
 236             branchcode => 'CPL',
 237             module => 'circulation',
 238             code => 'my code',
 239             [ mtt => 'email', ]
 240         }
 241     );
 242
 243     Delete the letter. The mtt parameter is facultative.
 244     If not given, all templates mathing the other parameters will be removed.
 245
 246 =cut
 247
 248 sub DelLetter {
 249     my ($params)   = @_;
 250     my $branchcode = $params->{branchcode};
 251     my $module     = $params->{module};
 252     my $code       = $params->{code};
 253     my $mtt        = $params->{mtt};
 254     my $dbh        = C4::Context->dbh;
 255     $dbh->do(q|
 256         DELETE FROM letter
 257         WHERE branchcode = ?
 258           AND module = ?
 259           AND code = ?
 260     | . ( $mtt ? q| AND message_transport_type = ?| : q|| )
 261     , undef, $branchcode, $module, $code, ( $mtt ? $mtt : () ) );
 262 }
 263
 264 =head2 addalert ($borrowernumber, $type, $externalid)
 265
 266     parameters :
 267     - $borrowernumber : the number of the borrower subscribing to the alert
 268     - $type : the type of alert.
 269     - $externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid.
 270
 271     create an alert and return the alertid (primary key)
 272
 273 =cut
 274
 275 sub addalert {
 276     my ( $borrowernumber, $type, $externalid ) = @_;
 277     my $dbh = C4::Context->dbh;
 278     my $sth =
 279       $dbh->prepare(
 280         "insert into alert (borrowernumber, type, externalid) values (?,?,?)");
 281     $sth->execute( $borrowernumber, $type, $externalid );
 282
 283     # get the alert number newly created and return it
 284     my $alertid = $dbh->{'mysql_insertid'};
 285     return $alertid;
 286 }
 287
 288 =head2 delalert ($alertid)
 289
 290     parameters :
 291     - alertid : the alert id
 292     deletes the alert
 293
 294 =cut
 295
 296 sub delalert {
 297     my $alertid = shift or die "delalert() called without valid argument (alertid)";    # it's gonna die anyway.
 298     $debug and warn "delalert: deleting alertid $alertid";
 299     my $sth = C4::Context->dbh->prepare("delete from alert where alertid=?");
 300     $sth->execute($alertid);
 301 }
 302
 303 =head2 getalert ([$borrowernumber], [$type], [$externalid])
 304
 305     parameters :
 306     - $borrowernumber : the number of the borrower subscribing to the alert
 307     - $type : the type of alert.
 308     - $externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid.
 309     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.
 310
 311 =cut
 312
 313 sub getalert {
 314     my ( $borrowernumber, $type, $externalid ) = @_;
 315     my $dbh   = C4::Context->dbh;
 316     my $query = "SELECT a.*, b.branchcode FROM alert a JOIN borrowers b USING(borrowernumber) WHERE 1";
 317     my @bind;
 318     if ($borrowernumber and $borrowernumber =~ /^\d+$/) {
 319         $query .= " AND borrowernumber=?";
 320         push @bind, $borrowernumber;
 321     }
 322     if ($type) {
 323         $query .= " AND type=?";
 324         push @bind, $type;
 325     }
 326     if ($externalid) {
 327         $query .= " AND externalid=?";
 328         push @bind, $externalid;
 329     }
 330     my $sth = $dbh->prepare($query);
 331     $sth->execute(@bind);
 332     return $sth->fetchall_arrayref({});
 333 }
 334
 335 =head2 findrelatedto($type, $externalid)
 336
 337     parameters :
 338     - $type : the type of alert
 339     - $externalid : the id of the "object" to query
 340
 341     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.
 342     When type=issue, the id is related to a subscriptionid and this sub returns the name of the biblio.
 343
 344 =cut
 345
 346 # outmoded POD:
 347 # When type=virtual, the id is related to a virtual shelf and this sub returns the name of the sub
 348
 349 sub findrelatedto {
 350     my $type       = shift or return;
 351     my $externalid = shift or return;
 352     my $q = ($type eq 'issue'   ) ?
 353 "select title as result from subscription left join biblio on subscription.biblionumber=biblio.biblionumber where subscriptionid=?" :
 354             ($type eq 'borrower') ?
 355 "select concat(firstname,' ',surname) from borrowers where borrowernumber=?" : undef;
 356     unless ($q) {
 357         warn "findrelatedto(): Illegal type '$type'";
 358         return;
 359     }
 360     my $sth = C4::Context->dbh->prepare($q);
 361     $sth->execute($externalid);
 362     my ($result) = $sth->fetchrow;
 363     return $result;
 364 }
 365
 366 =head2 SendAlerts
 367
 368     parameters :
 369     - $type : the type of alert
 370     - $externalid : the id of the "object" to query
 371     - $letter_code : the letter to send.
 372
 373     send an alert to all borrowers having put an alert on a given subject.
 374
 375 =cut
 376
 377 sub SendAlerts {
 378     my ( $type, $externalid, $letter_code ) = @_;
 379     my $dbh = C4::Context->dbh;
 380     if ( $type eq 'issue' ) {
 381
 382         # prepare the letter...
 383         # search the subscriptionid
 384         my $sth =
 385           $dbh->prepare(
 386             "SELECT subscriptionid FROM serial WHERE serialid=?");
 387         $sth->execute($externalid);
 388         my ($subscriptionid) = $sth->fetchrow
 389           or warn( "No subscription for '$externalid'" ),
 390              return;
 391
 392         # search the biblionumber
 393         $sth =
 394           $dbh->prepare(
 395             "SELECT biblionumber FROM subscription WHERE subscriptionid=?");
 396         $sth->execute($subscriptionid);
 397         my ($biblionumber) = $sth->fetchrow
 398           or warn( "No biblionumber for '$subscriptionid'" ),
 399              return;
 400
 401         my %letter;
 402         # find the list of borrowers to alert
 403         my $alerts = getalert( '', 'issue', $subscriptionid );
 404         foreach (@$alerts) {
 405             my $borinfo = C4::Members::GetMember('borrowernumber' => $_->{'borrowernumber'});
 406             my $email = $borinfo->{email} or next;
 407
 408 #                    warn "sending issues...";
 409             my $userenv = C4::Context->userenv;
 410             my $library = Koha::Libraries->find( $_->{branchcode} );
 411             my $letter = GetPreparedLetter (
 412                 module => 'serial',
 413                 letter_code => $letter_code,
 414                 branchcode => $userenv->{branch},
 415                 tables => {
 416                     'branches'    => $_->{branchcode},
 417                     'biblio'      => $biblionumber,
 418                     'biblioitems' => $biblionumber,
 419                     'borrowers'   => $borinfo,
 420                     'subscription' => $subscriptionid,
 421                     'serial' => $externalid,
 422                 },
 423                 want_librarian => 1,
 424             ) or return;
 425
 426             # ... then send mail
 427             my $message = Koha::Email->new();
 428             my %mail = $message->create_message_headers(
 429                 {
 430                     to      => $email,
 431                     from    => $library->branchemail,
 432                     replyto => $library->branchreplyto,
 433                     sender  => $library->branchreturnpath,
 434                     subject => Encode::encode( "UTF-8", "" . $letter->{title} ),
 435                     message => $letter->{'is_html'}
 436                                 ? _wrap_html( Encode::encode( "UTF-8", $letter->{'content'} ),
 437                                               Encode::encode( "UTF-8", "" . $letter->{'title'} ))
 438                                 : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
 439                     contenttype => $letter->{'is_html'}
 440                                     ? 'text/html; charset="utf-8"'
 441                                     : 'text/plain; charset="utf-8"',
 442                 }
 443             );
 444             sendmail(%mail) or carp $Mail::Sendmail::error;
 445         }
 446     }
 447     elsif ( $type eq 'claimacquisition' or $type eq 'claimissues' ) {
 448
 449         # prepare the letter...
 450         # search the biblionumber
 451         my $strsth =  $type eq 'claimacquisition'
 452             ? qq{
 453             SELECT aqorders.*,aqbasket.*,biblio.*,biblioitems.*
 454             FROM aqorders
 455             LEFT JOIN aqbasket ON aqbasket.basketno=aqorders.basketno
 456             LEFT JOIN biblio ON aqorders.biblionumber=biblio.biblionumber
 457             LEFT JOIN biblioitems ON aqorders.biblionumber=biblioitems.biblionumber
 458             WHERE aqorders.ordernumber IN (
 459             }
 460             : qq{
 461             SELECT serial.*,subscription.*, biblio.*, aqbooksellers.*,
 462             aqbooksellers.id AS booksellerid
 463             FROM serial
 464             LEFT JOIN subscription ON serial.subscriptionid=subscription.subscriptionid
 465             LEFT JOIN biblio ON serial.biblionumber=biblio.biblionumber
 466             LEFT JOIN aqbooksellers ON subscription.aqbooksellerid=aqbooksellers.id
 467             WHERE serial.serialid IN (
 468             };
 469
 470         if (!@$externalid){
 471             carp "No Order seleted";
 472             return { error => "no_order_seleted" };
 473         }
 474
 475         $strsth .= join( ",", @$externalid ) . ")";
 476         my $sthorders = $dbh->prepare($strsth);
 477         $sthorders->execute;
 478         my $dataorders = $sthorders->fetchall_arrayref( {} );
 479
 480         my $sthbookseller =
 481           $dbh->prepare("select * from aqbooksellers where id=?");
 482         $sthbookseller->execute( $dataorders->[0]->{booksellerid} );
 483         my $databookseller = $sthbookseller->fetchrow_hashref;
 484         my $addressee =  $type eq 'claimacquisition' ? 'acqprimary' : 'serialsprimary';
 485         my $sthcontact =
 486           $dbh->prepare("SELECT * FROM aqcontacts WHERE booksellerid=? AND $type=1 ORDER BY $addressee DESC");
 487         $sthcontact->execute( $dataorders->[0]->{booksellerid} );
 488         my $datacontact = $sthcontact->fetchrow_hashref;
 489
 490         my @email;
 491         my @cc;
 492         push @email, $databookseller->{bookselleremail} if $databookseller->{bookselleremail};
 493         push @email, $datacontact->{email}           if ( $datacontact && $datacontact->{email} );
 494         unless (@email) {
 495             warn "Bookseller $dataorders->[0]->{booksellerid} without emails";
 496             return { error => "no_email" };
 497         }
 498         my $addlcontact;
 499         while ($addlcontact = $sthcontact->fetchrow_hashref) {
 500             push @cc, $addlcontact->{email} if ( $addlcontact && $addlcontact->{email} );
 501         }
 502
 503         my $userenv = C4::Context->userenv;
 504         my $letter = GetPreparedLetter (
 505             module => $type,
 506             letter_code => $letter_code,
 507             branchcode => $userenv->{branch},
 508             tables => {
 509                 'branches'    => $userenv->{branch},
 510                 'aqbooksellers' => $databookseller,
 511                 'aqcontacts'    => $datacontact,
 512             },
 513             repeat => $dataorders,
 514             want_librarian => 1,
 515         ) or return;
 516
 517         # Remove the order tag
 518         $letter->{content} =~ s/<order>(.*?)<\/order>/$1/gxms;
 519
 520         # ... then send mail
 521         my %mail = (
 522             To => join( ',', @email),
 523             Cc             => join( ',', @cc),
 524             From           => $userenv->{emailaddress},
 525             Subject        => Encode::encode( "UTF-8", "" . $letter->{title} ),
 526             Message => $letter->{'is_html'}
 527                             ? _wrap_html( Encode::encode( "UTF-8", $letter->{'content'} ),
 528                                           Encode::encode( "UTF-8", "" . $letter->{'title'} ))
 529                             : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
 530             'Content-Type' => $letter->{'is_html'}
 531                                 ? 'text/html; charset="utf-8"'
 532                                 : 'text/plain; charset="utf-8"',
 533         );
 534
 535         $mail{'Reply-to'} = C4::Context->preference('ReplytoDefault')
 536           if C4::Context->preference('ReplytoDefault');
 537         $mail{'Sender'} = C4::Context->preference('ReturnpathDefault')
 538           if C4::Context->preference('ReturnpathDefault');
 539         $mail{'Bcc'} = $userenv->{emailaddress}
 540           if C4::Context->preference("ClaimsBccCopy");
 541
 542         unless ( sendmail(%mail) ) {
 543             carp $Mail::Sendmail::error;
 544             return { error => $Mail::Sendmail::error };
 545         }
 546
 547         logaction(
 548             "ACQUISITION",
 549             $type eq 'claimissues' ? "CLAIM ISSUE" : "ACQUISITION CLAIM",
 550             undef,
 551             "To="
 552                 . join( ',', @email )
 553                 . " Title="
 554                 . $letter->{title}
 555                 . " Content="
 556                 . $letter->{content}
 557         ) if C4::Context->preference("LetterLog");
 558     }
 559    # send an "account details" notice to a newly created user
 560     elsif ( $type eq 'members' ) {
 561         my $library = Koha::Libraries->find( $externalid->{branchcode} )->unblessed;
 562         my $letter = GetPreparedLetter (
 563             module => 'members',
 564             letter_code => $letter_code,
 565             branchcode => $externalid->{'branchcode'},
 566             tables => {
 567                 'branches'    => $library,
 568                 'borrowers' => $externalid->{'borrowernumber'},
 569             },
 570             substitute => { 'borrowers.password' => $externalid->{'password'} },
 571             want_librarian => 1,
 572         ) or return;
 573         return { error => "no_email" } unless $externalid->{'emailaddr'};
 574         my $email = Koha::Email->new();
 575         my %mail  = $email->create_message_headers(
 576             {
 577                 to      => $externalid->{'emailaddr'},
 578                 from    => $library->{branchemail},
 579                 replyto => $library->{branchreplyto},
 580                 sender  => $library->{branchreturnpath},
 581                 subject => Encode::encode( "UTF-8", "" . $letter->{'title'} ),
 582                 message => $letter->{'is_html'}
 583                             ? _wrap_html( Encode::encode( "UTF-8", $letter->{'content'} ),
 584                                           Encode::encode( "UTF-8", "" . $letter->{'title'}  ) )
 585                             : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
 586                 contenttype => $letter->{'is_html'}
 587                                 ? 'text/html; charset="utf-8"'
 588                                 : 'text/plain; charset="utf-8"',
 589             }
 590         );
 591         sendmail(%mail) or carp $Mail::Sendmail::error;
 592     }
 593 }
 594
 595 =head2 GetPreparedLetter( %params )
 596
 597     %params hash:
 598       module => letter module, mandatory
 599       letter_code => letter code, mandatory
 600       branchcode => for letter selection, if missing default system letter taken
 601       tables => a hashref with table names as keys. Values are either:
 602         - a scalar - primary key value
 603         - an arrayref - primary key values
 604         - a hashref - full record
 605       substitute => custom substitution key/value pairs
 606       repeat => records to be substituted on consecutive lines:
 607         - an arrayref - tries to guess what needs substituting by
 608           taking remaining << >> tokensr; not recommended
 609         - a hashref token => @tables - replaces <token> << >> << >> </token>
 610           subtemplate for each @tables row; table is a hashref as above
 611       want_librarian => boolean,  if set to true triggers librarian details
 612         substitution from the userenv
 613     Return value:
 614       letter fields hashref (title & content useful)
 615
 616 =cut
 617
 618 sub GetPreparedLetter {
 619     my %params = @_;
 620
 621     my $module      = $params{module} or croak "No module";
 622     my $letter_code = $params{letter_code} or croak "No letter_code";
 623     my $branchcode  = $params{branchcode} || '';
 624     my $mtt         = $params{message_transport_type} || 'email';
 625
 626     my $letter = getletter( $module, $letter_code, $branchcode, $mtt )
 627         or warn( "No $module $letter_code letter transported by " . $mtt ),
 628             return;
 629
 630     my $tables = $params{tables};
 631     my $substitute = $params{substitute};
 632     my $repeat = $params{repeat};
 633     $tables || $substitute || $repeat
 634       or carp( "ERROR: nothing to substitute - both 'tables' and 'substitute' are empty" ),
 635          return;
 636     my $want_librarian = $params{want_librarian};
 637
 638     if ($substitute) {
 639         while ( my ($token, $val) = each %$substitute ) {
 640             if ( $token eq 'items.content' ) {
 641                 $val =~ s|\n|<br/>|g if $letter->{is_html};
 642             }
 643
 644             $letter->{title} =~ s/<<$token>>/$val/g;
 645             $letter->{content} =~ s/<<$token>>/$val/g;
 646        }
 647     }
 648
 649     my $OPACBaseURL = C4::Context->preference('OPACBaseURL');
 650     $letter->{content} =~ s/<<OPACBaseURL>>/$OPACBaseURL/go;
 651
 652     if ($want_librarian) {
 653         # parsing librarian name
 654         my $userenv = C4::Context->userenv;
 655         $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/go;
 656         $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/go;
 657         $letter->{content} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/go;
 658     }
 659
 660     my ($repeat_no_enclosing_tags, $repeat_enclosing_tags);
 661
 662     if ($repeat) {
 663         if (ref ($repeat) eq 'ARRAY' ) {
 664             $repeat_no_enclosing_tags = $repeat;
 665         } else {
 666             $repeat_enclosing_tags = $repeat;
 667         }
 668     }
 669
 670     if ($repeat_enclosing_tags) {
 671         while ( my ($tag, $tag_tables) = each %$repeat_enclosing_tags ) {
 672             if ( $letter->{content} =~ m!<$tag>(.*)</$tag>!s ) {
 673                 my $subcontent = $1;
 674                 my @lines = map {
 675                     my %subletter = ( title => '', content => $subcontent );
 676                     _substitute_tables( \%subletter, $_ );
 677                     $subletter{content};
 678                 } @$tag_tables;
 679                 $letter->{content} =~ s!<$tag>.*</$tag>!join( "\n", @lines )!se;
 680             }
 681         }
 682     }
 683
 684     if ($tables) {
 685         _substitute_tables( $letter, $tables );
 686     }
 687
 688     if ($repeat_no_enclosing_tags) {
 689         if ( $letter->{content} =~ m/[^\n]*<<.*>>[^\n]*/so ) {
 690             my $line = $&;
 691             my $i = 1;
 692             my @lines = map {
 693                 my $c = $line;
 694                 $c =~ s/<<count>>/$i/go;
 695                 foreach my $field ( keys %{$_} ) {
 696                     $c =~ s/(<<[^\.]+.$field>>)/$_->{$field}/;
 697                 }
 698                 $i++;
 699                 $c;
 700             } @$repeat_no_enclosing_tags;
 701
 702             my $replaceby = join( "\n", @lines );
 703             $letter->{content} =~ s/\Q$line\E/$replaceby/s;
 704         }
 705     }
 706
 707     $letter->{content} = _process_tt(
 708         {
 709             content => $letter->{content},
 710             tables  => $tables,
 711         }
 712     );
 713
 714     $letter->{content} =~ s/<<\S*>>//go; #remove any stragglers
 715
 716     return $letter;
 717 }
 718
 719 sub _substitute_tables {
 720     my ( $letter, $tables ) = @_;
 721     while ( my ($table, $param) = each %$tables ) {
 722         next unless $param;
 723
 724         my $ref = ref $param;
 725
 726         my $values;
 727         if ($ref && $ref eq 'HASH') {
 728             $values = $param;
 729         }
 730         else {
 731             my $sth = _parseletter_sth($table);
 732             unless ($sth) {
 733                 warn "_parseletter_sth('$table') failed to return a valid sth.  No substitution will be done for that table.";
 734                 return;
 735             }
 736             $sth->execute( $ref ? @$param : $param );
 737
 738             $values = $sth->fetchrow_hashref;
 739             $sth->finish();
 740         }
 741
 742         _parseletter ( $letter, $table, $values );
 743     }
 744 }
 745
 746 sub _parseletter_sth {
 747     my $table = shift;
 748     my $sth;
 749     unless ($table) {
 750         carp "ERROR: _parseletter_sth() called without argument (table)";
 751         return;
 752     }
 753     # NOTE: we used to check whether we had a statement handle cached in
 754     #       a %handles module-level variable. This was a dumb move and
 755     #       broke things for the rest of us. prepare_cached is a better
 756     #       way to cache statement handles anyway.
 757     my $query =
 758     ($table eq 'biblio'       ) ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 759     ($table eq 'biblioitems'  ) ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 760     ($table eq 'items'        ) ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 761     ($table eq 'issues'       ) ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 762     ($table eq 'old_issues'   ) ? "SELECT * FROM $table WHERE     itemnumber = ? ORDER BY timestamp DESC LIMIT 1"  :
 763     ($table eq 'reserves'     ) ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?"             :
 764     ($table eq 'borrowers'    ) ? "SELECT * FROM $table WHERE borrowernumber = ?"                                  :
 765     ($table eq 'branches'     ) ? "SELECT * FROM $table WHERE     branchcode = ?"                                  :
 766     ($table eq 'suggestions'  ) ? "SELECT * FROM $table WHERE   suggestionid = ?"                                  :
 767     ($table eq 'aqbooksellers') ? "SELECT * FROM $table WHERE             id = ?"                                  :
 768     ($table eq 'aqorders'     ) ? "SELECT * FROM $table WHERE    ordernumber = ?"                                  :
 769     ($table eq 'opac_news'    ) ? "SELECT * FROM $table WHERE          idnew = ?"                                  :
 770     ($table eq 'borrower_modifications') ? "SELECT * FROM $table WHERE verification_token = ?" :
 771     ($table eq 'subscription') ? "SELECT * FROM $table WHERE subscriptionid = ?" :
 772     ($table eq 'serial') ? "SELECT * FROM $table WHERE serialid = ?" :
 773     undef ;
 774     unless ($query) {
 775         warn "ERROR: No _parseletter_sth query for table '$table'";
 776         return;     # nothing to get
 777     }
 778     unless ($sth = C4::Context->dbh->prepare_cached($query)) {
 779         warn "ERROR: Failed to prepare query: '$query'";
 780         return;
 781     }
 782     return $sth;    # now cache is populated for that $table
 783 }
 784
 785 =head2 _parseletter($letter, $table, $values)
 786
 787     parameters :
 788     - $letter : a hash to letter fields (title & content useful)
 789     - $table : the Koha table to parse.
 790     - $values_in : table record hashref
 791     parse all fields from a table, and replace values in title & content with the appropriate value
 792     (not exported sub, used only internally)
 793
 794 =cut
 795
 796 sub _parseletter {
 797     my ( $letter, $table, $values_in ) = @_;
 798
 799     # Work on a local copy of $values_in (passed by reference) to avoid side effects
 800     # in callers ( by changing / formatting values )
 801     my $values = $values_in ? { %$values_in } : {};
 802
 803     if ( $table eq 'borrowers' && $values->{'dateexpiry'} ){
 804         $values->{'dateexpiry'} = format_sqldatetime( $values->{'dateexpiry'} );
 805     }
 806
 807     if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
 808         my @waitingdate = split /-/, $values->{'waitingdate'};
 809
 810         $values->{'expirationdate'} = '';
 811         if ( C4::Context->preference('ReservesMaxPickUpDelay') ) {
 812             my $dt = dt_from_string();
 813             $dt->add( days => C4::Context->preference('ReservesMaxPickUpDelay') );
 814             $values->{'expirationdate'} = output_pref( { dt => $dt, dateonly => 1 } );
 815         }
 816
 817         $values->{'waitingdate'} = output_pref({ dt => dt_from_string( $values->{'waitingdate'} ), dateonly => 1 });
 818
 819     }
 820
 821     if ($letter->{content} && $letter->{content} =~ /<<today>>/) {
 822         my $todaysdate = output_pref( DateTime->now() );
 823         $letter->{content} =~ s/<<today>>/$todaysdate/go;
 824     }
 825
 826     while ( my ($field, $val) = each %$values ) {
 827         $val =~ s/\p{P}$// if $val && $table=~/biblio/;
 828             #BZ 9886: Assuming that we want to eliminate ISBD punctuation here
 829             #Therefore adding the test on biblio. This includes biblioitems,
 830             #but excludes items. Removed unneeded global and lookahead.
 831
 832         $val = GetAuthorisedValueByCode ('ROADTYPE', $val, 0) if $table=~/^borrowers$/ && $field=~/^streettype$/;
 833
 834         # Dates replacement
 835         my $replacedby   = defined ($val) ? $val : '';
 836         if (    $replacedby
 837             and not $replacedby =~ m|0000-00-00|
 838             and not $replacedby =~ m|9999-12-31|
 839             and $replacedby =~ m|^\d{4}-\d{2}-\d{2}( \d{2}:\d{2}:\d{2})?$| )
 840         {
 841             # If the value is XXXX-YY-ZZ[ AA:BB:CC] we assume it is a date
 842             my $dateonly = defined $1 ? 0 : 1; #$1 refers to the capture group wrapped in parentheses. In this case, that's the hours, minutes, seconds.
 843             my $re_dateonly_filter = qr{ $field( \s* \| \s* dateonly\s*)?>> }xms;
 844
 845             for my $letter_field ( qw( title content ) ) {
 846                 my $filter_string_used = q{};
 847                 if ( $letter->{ $letter_field } =~ $re_dateonly_filter ) {
 848                     # We overwrite $dateonly if the filter exists and we have a time in the datetime
 849                     $filter_string_used = $1 || q{};
 850                     $dateonly = $1 unless $dateonly;
 851                 }
 852                 my $replacedby_date = eval {
 853                     output_pref({ dt => dt_from_string( $replacedby ), dateonly => $dateonly });
 854                 };
 855
 856                 if ( $letter->{ $letter_field } ) {
 857                     $letter->{ $letter_field } =~ s/\Q<<$table.$field$filter_string_used>>\E/$replacedby_date/g;
 858                     $letter->{ $letter_field } =~ s/\Q<<$field$filter_string_used>>\E/$replacedby_date/g;
 859                 }
 860             }
 861         }
 862         # Other fields replacement
 863         else {
 864             for my $letter_field ( qw( title content ) ) {
 865                 if ( $letter->{ $letter_field } ) {
 866                     $letter->{ $letter_field }   =~ s/<<$table.$field>>/$replacedby/g;
 867                     $letter->{ $letter_field }   =~ s/<<$field>>/$replacedby/g;
 868                 }
 869             }
 870         }
 871     }
 872
 873     if ($table eq 'borrowers' && $letter->{content}) {
 874         if ( my $attributes = GetBorrowerAttributes($values->{borrowernumber}) ) {
 875             my %attr;
 876             foreach (@$attributes) {
 877                 my $code = $_->{code};
 878                 my $val  = $_->{value_description} || $_->{value};
 879                 $val =~ s/\p{P}(?=$)//g if $val;
 880                 next unless $val gt '';
 881                 $attr{$code} ||= [];
 882                 push @{ $attr{$code} }, $val;
 883             }
 884             while ( my ($code, $val_ar) = each %attr ) {
 885                 my $replacefield = "<<borrower-attribute:$code>>";
 886                 my $replacedby   = join ',', @$val_ar;
 887                 $letter->{content} =~ s/$replacefield/$replacedby/g;
 888             }
 889         }
 890     }
 891     return $letter;
 892 }
 893
 894 =head2 EnqueueLetter
 895
 896   my $success = EnqueueLetter( { letter => $letter,
 897         borrowernumber => '12', message_transport_type => 'email' } )
 898
 899 places a letter in the message_queue database table, which will
 900 eventually get processed (sent) by the process_message_queue.pl
 901 cronjob when it calls SendQueuedMessages.
 902
 903 return message_id on success
 904
 905 =cut
 906
 907 sub EnqueueLetter {
 908     my $params = shift or return;
 909
 910     return unless exists $params->{'letter'};
 911 #   return unless exists $params->{'borrowernumber'};
 912     return unless exists $params->{'message_transport_type'};
 913
 914     my $content = $params->{letter}->{content};
 915     $content =~ s/\s+//g if(defined $content);
 916     if ( not defined $content or $content eq '' ) {
 917         warn "Trying to add an empty message to the message queue" if $debug;
 918         return;
 919     }
 920
 921     # If we have any attachments we should encode then into the body.
 922     if ( $params->{'attachments'} ) {
 923         $params->{'letter'} = _add_attachments(
 924             {   letter      => $params->{'letter'},
 925                 attachments => $params->{'attachments'},
 926                 message     => MIME::Lite->new( Type => 'multipart/mixed' ),
 927             }
 928         );
 929     }
 930
 931     my $dbh       = C4::Context->dbh();
 932     my $statement = << 'ENDSQL';
 933 INSERT INTO message_queue
 934 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type )
 935 VALUES
 936 ( ?,              ?,       ?,       ?,        ?,           ?,                      ?,      NOW(),       ?,          ?,            ? )
 937 ENDSQL
 938
 939     my $sth    = $dbh->prepare($statement);
 940     my $result = $sth->execute(
 941         $params->{'borrowernumber'},              # borrowernumber
 942         $params->{'letter'}->{'title'},           # subject
 943         $params->{'letter'}->{'content'},         # content
 944         $params->{'letter'}->{'metadata'} || '',  # metadata
 945         $params->{'letter'}->{'code'}     || '',  # letter_code
 946         $params->{'message_transport_type'},      # message_transport_type
 947         'pending',                                # status
 948         $params->{'to_address'},                  # to_address
 949         $params->{'from_address'},                # from_address
 950         $params->{'letter'}->{'content-type'},    # content_type
 951     );
 952     return $dbh->last_insert_id(undef,undef,'message_queue', undef);
 953 }
 954
 955 =head2 SendQueuedMessages ([$hashref])
 956
 957   my $sent = SendQueuedMessages( { verbose => 1 } );
 958
 959 sends all of the 'pending' items in the message queue.
 960
 961 returns number of messages sent.
 962
 963 =cut
 964
 965 sub SendQueuedMessages {
 966     my $params = shift;
 967
 968     my $unsent_messages = _get_unsent_messages();
 969     MESSAGE: foreach my $message ( @$unsent_messages ) {
 970         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
 971         warn sprintf( 'sending %s message to patron: %s',
 972                       $message->{'message_transport_type'},
 973                       $message->{'borrowernumber'} || 'Admin' )
 974           if $params->{'verbose'} or $debug;
 975         # This is just begging for subclassing
 976         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
 977         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
 978             _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
 979         }
 980         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
 981             if ( C4::Context->preference('SMSSendDriver') eq 'Email' ) {
 982                 my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
 983                 my $sms_provider = Koha::SMS::Providers->find( $member->{'sms_provider_id'} );
 984                 $message->{to_address} .= '@' . $sms_provider->domain();
 985                 _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
 986             } else {
 987                 _send_message_by_sms( $message );
 988             }
 989         }
 990     }
 991     return scalar( @$unsent_messages );
 992 }
 993
 994 =head2 GetRSSMessages
 995
 996   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
 997
 998 returns a listref of all queued RSS messages for a particular person.
 999
1000 =cut
1001
1002 sub GetRSSMessages {
1003     my $params = shift;
1004
1005     return unless $params;
1006     return unless ref $params;
1007     return unless $params->{'borrowernumber'};
1008
1009     return _get_unsent_messages( { message_transport_type => 'rss',
1010                                    limit                  => $params->{'limit'},
1011                                    borrowernumber         => $params->{'borrowernumber'}, } );
1012 }
1013
1014 =head2 GetPrintMessages
1015
1016   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
1017
1018 Returns a arrayref of all queued print messages (optionally, for a particular
1019 person).
1020
1021 =cut
1022
1023 sub GetPrintMessages {
1024     my $params = shift || {};
1025
1026     return _get_unsent_messages( { message_transport_type => 'print',
1027                                    borrowernumber         => $params->{'borrowernumber'},
1028                                  } );
1029 }
1030
1031 =head2 GetQueuedMessages ([$hashref])
1032
1033   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
1034
1035 fetches messages out of the message queue.
1036
1037 returns:
1038 list of hashes, each has represents a message in the message queue.
1039
1040 =cut
1041
1042 sub GetQueuedMessages {
1043     my $params = shift;
1044
1045     my $dbh = C4::Context->dbh();
1046     my $statement = << 'ENDSQL';
1047 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued
1048 FROM message_queue
1049 ENDSQL
1050
1051     my @query_params;
1052     my @whereclauses;
1053     if ( exists $params->{'borrowernumber'} ) {
1054         push @whereclauses, ' borrowernumber = ? ';
1055         push @query_params, $params->{'borrowernumber'};
1056     }
1057
1058     if ( @whereclauses ) {
1059         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
1060     }
1061
1062     if ( defined $params->{'limit'} ) {
1063         $statement .= ' LIMIT ? ';
1064         push @query_params, $params->{'limit'};
1065     }
1066
1067     my $sth = $dbh->prepare( $statement );
1068     my $result = $sth->execute( @query_params );
1069     return $sth->fetchall_arrayref({});
1070 }
1071
1072 =head2 GetMessageTransportTypes
1073
1074   my @mtt = GetMessageTransportTypes();
1075
1076   returns an arrayref of transport types
1077
1078 =cut
1079
1080 sub GetMessageTransportTypes {
1081     my $dbh = C4::Context->dbh();
1082     my $mtts = $dbh->selectcol_arrayref("
1083         SELECT message_transport_type
1084         FROM message_transport_types
1085         ORDER BY message_transport_type
1086     ");
1087     return $mtts;
1088 }
1089
1090 =head2 GetMessage
1091
1092     my $message = C4::Letters::Message($message_id);
1093
1094 =cut
1095
1096 sub GetMessage {
1097     my ( $message_id ) = @_;
1098     return unless $message_id;
1099     my $dbh = C4::Context->dbh;
1100     return $dbh->selectrow_hashref(q|
1101         SELECT message_id, borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type
1102         FROM message_queue
1103         WHERE message_id = ?
1104     |, {}, $message_id );
1105 }
1106
1107 =head2 ResendMessage
1108
1109   Attempt to resend a message which has failed previously.
1110
1111   my $has_been_resent = C4::Letters::ResendMessage($message_id);
1112
1113   Updates the message to 'pending' status so that
1114   it will be resent later on.
1115
1116   returns 1 on success, 0 on failure, undef if no message was found
1117
1118 =cut
1119
1120 sub ResendMessage {
1121     my $message_id = shift;
1122     return unless $message_id;
1123
1124     my $message = GetMessage( $message_id );
1125     return unless $message;
1126     my $rv = 0;
1127     if ( $message->{status} ne 'pending' ) {
1128         $rv = C4::Letters::_set_message_status({
1129             message_id => $message_id,
1130             status => 'pending',
1131         });
1132         $rv = $rv > 0? 1: 0;
1133         # Clear destination email address to force address update
1134         _update_message_to_address( $message_id, undef ) if $rv &&
1135             $message->{message_transport_type} eq 'email';
1136     }
1137     return $rv;
1138 }
1139
1140 =head2 _add_attachements
1141
1142 named parameters:
1143 letter - the standard letter hashref
1144 attachments - listref of attachments. each attachment is a hashref of:
1145   type - the mime type, like 'text/plain'
1146   content - the actual attachment
1147   filename - the name of the attachment.
1148 message - a MIME::Lite object to attach these to.
1149
1150 returns your letter object, with the content updated.
1151
1152 =cut
1153
1154 sub _add_attachments {
1155     my $params = shift;
1156
1157     my $letter = $params->{'letter'};
1158     my $attachments = $params->{'attachments'};
1159     return $letter unless @$attachments;
1160     my $message = $params->{'message'};
1161
1162     # First, we have to put the body in as the first attachment
1163     $message->attach(
1164         Type => $letter->{'content-type'} || 'TEXT',
1165         Data => $letter->{'is_html'}
1166             ? _wrap_html($letter->{'content'}, $letter->{'title'})
1167             : $letter->{'content'},
1168     );
1169
1170     foreach my $attachment ( @$attachments ) {
1171         $message->attach(
1172             Type     => $attachment->{'type'},
1173             Data     => $attachment->{'content'},
1174             Filename => $attachment->{'filename'},
1175         );
1176     }
1177     # we're forcing list context here to get the header, not the count back from grep.
1178     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
1179     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
1180     $letter->{'content'} = $message->body_as_string;
1181
1182     return $letter;
1183
1184 }
1185
1186 sub _get_unsent_messages {
1187     my $params = shift;
1188
1189     my $dbh = C4::Context->dbh();
1190     my $statement = << 'ENDSQL';
1191 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
1192   FROM message_queue mq
1193   LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
1194  WHERE status = ?
1195 ENDSQL
1196
1197     my @query_params = ('pending');
1198     if ( ref $params ) {
1199         if ( $params->{'message_transport_type'} ) {
1200             $statement .= ' AND message_transport_type = ? ';
1201             push @query_params, $params->{'message_transport_type'};
1202         }
1203         if ( $params->{'borrowernumber'} ) {
1204             $statement .= ' AND borrowernumber = ? ';
1205             push @query_params, $params->{'borrowernumber'};
1206         }
1207         if ( $params->{'limit'} ) {
1208             $statement .= ' limit ? ';
1209             push @query_params, $params->{'limit'};
1210         }
1211     }
1212
1213     $debug and warn "_get_unsent_messages SQL: $statement";
1214     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
1215     my $sth = $dbh->prepare( $statement );
1216     my $result = $sth->execute( @query_params );
1217     return $sth->fetchall_arrayref({});
1218 }
1219
1220 sub _send_message_by_email {
1221     my $message = shift or return;
1222     my ($username, $password, $method) = @_;
1223
1224     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
1225     my $to_address = $message->{'to_address'};
1226     unless ($to_address) {
1227         unless ($member) {
1228             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
1229             _set_message_status( { message_id => $message->{'message_id'},
1230                                    status     => 'failed' } );
1231             return;
1232         }
1233         $to_address = C4::Members::GetNoticeEmailAddress( $message->{'borrowernumber'} );
1234         unless ($to_address) {
1235             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
1236             # warning too verbose for this more common case?
1237             _set_message_status( { message_id => $message->{'message_id'},
1238                                    status     => 'failed' } );
1239             return;
1240         }
1241     }
1242
1243     my $utf8   = decode('MIME-Header', $message->{'subject'} );
1244     $message->{subject}= encode('MIME-Header', $utf8);
1245     my $subject = encode('UTF-8', $message->{'subject'});
1246     my $content = encode('UTF-8', $message->{'content'});
1247     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
1248     my $is_html = $content_type =~ m/html/io;
1249     my $branch_email = undef;
1250     my $branch_replyto = undef;
1251     my $branch_returnpath = undef;
1252     if ($member) {
1253         my $library = Koha::Libraries->find( $member->{branchcode} );
1254         $branch_email      = $library->branchemail;
1255         $branch_replyto    = $library->branchreplyto;
1256         $branch_returnpath = $library->branchreturnpath;
1257     }
1258     my $email = Koha::Email->new();
1259     my %sendmail_params = $email->create_message_headers(
1260         {
1261             to      => $to_address,
1262             from    => $message->{'from_address'} || $branch_email,
1263             replyto => $branch_replyto,
1264             sender  => $branch_returnpath,
1265             subject => $subject,
1266             message => $is_html ? _wrap_html( $content, $subject ) : $content,
1267             contenttype => $content_type
1268         }
1269     );
1270
1271     $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
1272     if ( my $bcc = C4::Context->preference('OverdueNoticeBcc') ) {
1273        $sendmail_params{ Bcc } = $bcc;
1274     }
1275
1276     _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
1277
1278     if ( sendmail( %sendmail_params ) ) {
1279         _set_message_status( { message_id => $message->{'message_id'},
1280                 status     => 'sent' } );
1281         return 1;
1282     } else {
1283         _set_message_status( { message_id => $message->{'message_id'},
1284                 status     => 'failed' } );
1285         carp $Mail::Sendmail::error;
1286         return;
1287     }
1288 }
1289
1290 sub _wrap_html {
1291     my ($content, $title) = @_;
1292
1293     my $css = C4::Context->preference("NoticeCSS") || '';
1294     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
1295     return <<EOS;
1296 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1297     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1298 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1299 <head>
1300 <title>$title</title>
1301 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1302 $css
1303 </head>
1304 <body>
1305 $content
1306 </body>
1307 </html>
1308 EOS
1309 }
1310
1311 sub _is_duplicate {
1312     my ( $message ) = @_;
1313     my $dbh = C4::Context->dbh;
1314     my $count = $dbh->selectrow_array(q|
1315         SELECT COUNT(*)
1316         FROM message_queue
1317         WHERE message_transport_type = ?
1318         AND borrowernumber = ?
1319         AND letter_code = ?
1320         AND CAST(time_queued AS date) = CAST(NOW() AS date)
1321         AND status="sent"
1322         AND content = ?
1323     |, {}, $message->{message_transport_type}, $message->{borrowernumber}, $message->{letter_code}, $message->{content} );
1324     return $count;
1325 }
1326
1327 sub _send_message_by_sms {
1328     my $message = shift or return;
1329     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
1330
1331     unless ( $member->{smsalertnumber} ) {
1332         _set_message_status( { message_id => $message->{'message_id'},
1333                                status     => 'failed' } );
1334         return;
1335     }
1336
1337     if ( _is_duplicate( $message ) ) {
1338         _set_message_status( { message_id => $message->{'message_id'},
1339                                status     => 'failed' } );
1340         return;
1341     }
1342
1343     my $success = C4::SMS->send_sms( { destination => $member->{'smsalertnumber'},
1344                                        message     => $message->{'content'},
1345                                      } );
1346     _set_message_status( { message_id => $message->{'message_id'},
1347                            status     => ($success ? 'sent' : 'failed') } );
1348     return $success;
1349 }
1350
1351 sub _update_message_to_address {
1352     my ($id, $to)= @_;
1353     my $dbh = C4::Context->dbh();
1354     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1355 }
1356
1357 sub _set_message_status {
1358     my $params = shift or return;
1359
1360     foreach my $required_parameter ( qw( message_id status ) ) {
1361         return unless exists $params->{ $required_parameter };
1362     }
1363
1364     my $dbh = C4::Context->dbh();
1365     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1366     my $sth = $dbh->prepare( $statement );
1367     my $result = $sth->execute( $params->{'status'},
1368                                 $params->{'message_id'} );
1369     return $result;
1370 }
1371
1372 sub _process_tt {
1373     my ( $params ) = @_;
1374
1375     my $content = $params->{content};
1376     my $tables = $params->{tables};
1377
1378     my $use_template_cache = C4::Context->config('template_cache_dir') && defined $ENV{GATEWAY_INTERFACE};
1379     my $template           = Template->new(
1380         {
1381             EVAL_PERL    => 1,
1382             ABSOLUTE     => 1,
1383             PLUGIN_BASE  => 'Koha::Template::Plugin',
1384             COMPILE_EXT  => $use_template_cache ? '.ttc' : '',
1385             COMPILE_DIR  => $use_template_cache ? C4::Context->config('template_cache_dir') : '',
1386             FILTERS      => {},
1387             ENCODING     => 'UTF-8',
1388         }
1389     ) or die Template->error();
1390
1391     my $tt_params = _get_tt_params( $tables );
1392
1393     my $output;
1394     $template->process( \$content, $tt_params, \$output ) || croak "ERROR PROCESSING TEMPLATE: " . $template->error();
1395
1396     return $output;
1397 }
1398
1399 sub _get_tt_params {
1400     my ($tables) = @_;
1401
1402     my $params;
1403
1404     my $config = {
1405         biblio => {
1406             module   => 'Koha::Biblios',
1407             singular => 'biblio',
1408             plural   => 'biblios',
1409             pk       => 'biblionumber',
1410         },
1411         borrowers => {
1412             module   => 'Koha::Patrons',
1413             singular => 'borrower',
1414             plural   => 'borrowers',
1415             pk       => 'borrowernumber',
1416         },
1417         branches => {
1418             module   => 'Koha::Libraries',
1419             singular => 'branch',
1420             plural   => 'branches',
1421             pk       => 'branchcode',
1422         },
1423         items => {
1424             module   => 'Koha::Items',
1425             singular => 'item',
1426             plural   => 'items',
1427             pk       => 'itemnumber',
1428         },
1429         opac_news => {
1430             module   => 'Koha::News',
1431             singular => 'news',
1432             plural   => 'news',
1433             pk       => 'idnew',
1434         },
1435         reserves => {
1436             module   => 'Koha::Holds',
1437             singular => 'hold',
1438             plural   => 'holds',
1439             fk       => [ 'borrowernumber', 'biblionumber' ],
1440         },
1441         serial => {
1442             module   => 'Koha::Serials',
1443             singular => 'serial',
1444             plural   => 'serials',
1445             pk       => 'serialid',
1446         },
1447         subscription => {
1448             module   => 'Koha::Subscriptions',
1449             singular => 'subscription',
1450             plural   => 'subscriptions',
1451             pk       => 'subscriptionid',
1452         },
1453         suggestions => {
1454             module   => 'Koha::Suggestions',
1455             singular => 'suggestion',
1456             plural   => 'suggestions',
1457             pk       => 'suggestionid',
1458         },
1459         issues => {
1460             module   => 'Koha::Checkouts',
1461             singular => 'checkout',
1462             plural   => 'checkouts',
1463             fk       => 'itemnumber',
1464         },
1465         borrower_modifications => {
1466             module   => 'Koha::Patron::Modifications',
1467             singular => 'patron_modification',
1468             plural   => 'patron_modifications',
1469             fk       => 'verification_token',
1470         },
1471     };
1472
1473     foreach my $table ( keys %$tables ) {
1474         next unless $config->{$table};
1475
1476         my $ref = ref( $tables->{$table} ) || q{};
1477         my $module = $config->{$table}->{module};
1478
1479         if ( can_load( modules => { $module => undef } ) ) {
1480             my $pk = $config->{$table}->{pk};
1481             my $fk = $config->{$table}->{fk};
1482
1483             if ( $ref eq q{} || $ref eq 'HASH' ) {
1484                 my $id = ref $ref eq 'HASH' ? $tables->{$table}->{$pk} : $tables->{$table};
1485                 my $object;
1486                 if ( $fk ) { # Using a foreign key for lookup
1487                     if ( ref( $fk ) eq 'ARRAY' ) { # Foreign key is multi-column
1488                         my $search;
1489                         foreach my $key ( @$fk ) {
1490                             $search->{$key} = $id->{$key};
1491                         }
1492                         $object = $module->search( $search )->next();
1493                     } else { # Foreign key is single column
1494                         $object = $module->search( { $fk => $id } )->next();
1495                     }
1496                 } else { # using the table's primary key for lookup
1497                     $object = $module->find($id);
1498                 }
1499                 $params->{ $config->{$table}->{singular} } = $object;
1500             }
1501             else {    # $ref eq 'ARRAY'
1502                 my $object;
1503                 if ( @{ $tables->{$table} } == 1 ) {    # Param is a single key
1504                     $object = $module->search( { $pk => $tables->{$table} } )->next();
1505                 }
1506                 else {                                  # Params are mutliple foreign keys
1507                     my @values = @{ $tables->{$table} };
1508                     my @keys   = @{ $config->{$table}->{fk} };
1509                     my %params = map { $_ => shift(@values) } @keys;
1510                     $object = $module->search( \%params )->next();
1511                 }
1512                 $params->{ $config->{$table}->{singular} } = $object;
1513             }
1514         }
1515         else {
1516             croak "ERROR LOADING MODULE $module: $Module::Load::Conditional::ERROR";
1517         }
1518     }
1519
1520     $params->{today} = dt_from_string();
1521
1522     return $params;
1523 }
1524
1525
1526 1;
1527 __END__