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         1;
 559     }
 560    # send an "account details" notice to a newly created user
 561     elsif ( $type eq 'members' ) {
 562         my $library = Koha::Libraries->find( $externalid->{branchcode} )->unblessed;
 563         my $letter = GetPreparedLetter (
 564             module => 'members',
 565             letter_code => $letter_code,
 566             branchcode => $externalid->{'branchcode'},
 567             tables => {
 568                 'branches'    => $library,
 569                 'borrowers' => $externalid->{'borrowernumber'},
 570             },
 571             substitute => { 'borrowers.password' => $externalid->{'password'} },
 572             want_librarian => 1,
 573         ) or return;
 574         return { error => "no_email" } unless $externalid->{'emailaddr'};
 575         my $email = Koha::Email->new();
 576         my %mail  = $email->create_message_headers(
 577             {
 578                 to      => $externalid->{'emailaddr'},
 579                 from    => $library->{branchemail},
 580                 replyto => $library->{branchreplyto},
 581                 sender  => $library->{branchreturnpath},
 582                 subject => Encode::encode( "UTF-8", "" . $letter->{'title'} ),
 583                 message => $letter->{'is_html'}
 584                             ? _wrap_html( Encode::encode( "UTF-8", $letter->{'content'} ),
 585                                           Encode::encode( "UTF-8", "" . $letter->{'title'}  ) )
 586                             : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
 587                 contenttype => $letter->{'is_html'}
 588                                 ? 'text/html; charset="utf-8"'
 589                                 : 'text/plain; charset="utf-8"',
 590             }
 591         );
 592         sendmail(%mail) or carp $Mail::Sendmail::error;
 593     }
 594 }
 595
 596 =head2 GetPreparedLetter( %params )
 597
 598     %params hash:
 599       module => letter module, mandatory
 600       letter_code => letter code, mandatory
 601       branchcode => for letter selection, if missing default system letter taken
 602       tables => a hashref with table names as keys. Values are either:
 603         - a scalar - primary key value
 604         - an arrayref - primary key values
 605         - a hashref - full record
 606       substitute => custom substitution key/value pairs
 607       repeat => records to be substituted on consecutive lines:
 608         - an arrayref - tries to guess what needs substituting by
 609           taking remaining << >> tokensr; not recommended
 610         - a hashref token => @tables - replaces <token> << >> << >> </token>
 611           subtemplate for each @tables row; table is a hashref as above
 612       want_librarian => boolean,  if set to true triggers librarian details
 613         substitution from the userenv
 614     Return value:
 615       letter fields hashref (title & content useful)
 616
 617 =cut
 618
 619 sub GetPreparedLetter {
 620     my %params = @_;
 621
 622     my $module      = $params{module} or croak "No module";
 623     my $letter_code = $params{letter_code} or croak "No letter_code";
 624     my $branchcode  = $params{branchcode} || '';
 625     my $mtt         = $params{message_transport_type} || 'email';
 626
 627     my $letter = getletter( $module, $letter_code, $branchcode, $mtt )
 628         or warn( "No $module $letter_code letter transported by " . $mtt ),
 629             return;
 630
 631     my $tables = $params{tables};
 632     my $substitute = $params{substitute};
 633     my $repeat = $params{repeat};
 634     $tables || $substitute || $repeat
 635       or carp( "ERROR: nothing to substitute - both 'tables' and 'substitute' are empty" ),
 636          return;
 637     my $want_librarian = $params{want_librarian};
 638
 639     if ($substitute) {
 640         while ( my ($token, $val) = each %$substitute ) {
 641             if ( $token eq 'items.content' ) {
 642                 $val =~ s|\n|<br/>|g if $letter->{is_html};
 643             }
 644
 645             $letter->{title} =~ s/<<$token>>/$val/g;
 646             $letter->{content} =~ s/<<$token>>/$val/g;
 647        }
 648     }
 649
 650     my $OPACBaseURL = C4::Context->preference('OPACBaseURL');
 651     $letter->{content} =~ s/<<OPACBaseURL>>/$OPACBaseURL/go;
 652
 653     if ($want_librarian) {
 654         # parsing librarian name
 655         my $userenv = C4::Context->userenv;
 656         $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/go;
 657         $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/go;
 658         $letter->{content} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/go;
 659     }
 660
 661     my ($repeat_no_enclosing_tags, $repeat_enclosing_tags);
 662
 663     if ($repeat) {
 664         if (ref ($repeat) eq 'ARRAY' ) {
 665             $repeat_no_enclosing_tags = $repeat;
 666         } else {
 667             $repeat_enclosing_tags = $repeat;
 668         }
 669     }
 670
 671     if ($repeat_enclosing_tags) {
 672         while ( my ($tag, $tag_tables) = each %$repeat_enclosing_tags ) {
 673             if ( $letter->{content} =~ m!<$tag>(.*)</$tag>!s ) {
 674                 my $subcontent = $1;
 675                 my @lines = map {
 676                     my %subletter = ( title => '', content => $subcontent );
 677                     _substitute_tables( \%subletter, $_ );
 678                     $subletter{content};
 679                 } @$tag_tables;
 680                 $letter->{content} =~ s!<$tag>.*</$tag>!join( "\n", @lines )!se;
 681             }
 682         }
 683     }
 684
 685     if ($tables) {
 686         _substitute_tables( $letter, $tables );
 687     }
 688
 689     if ($repeat_no_enclosing_tags) {
 690         if ( $letter->{content} =~ m/[^\n]*<<.*>>[^\n]*/so ) {
 691             my $line = $&;
 692             my $i = 1;
 693             my @lines = map {
 694                 my $c = $line;
 695                 $c =~ s/<<count>>/$i/go;
 696                 foreach my $field ( keys %{$_} ) {
 697                     $c =~ s/(<<[^\.]+.$field>>)/$_->{$field}/;
 698                 }
 699                 $i++;
 700                 $c;
 701             } @$repeat_no_enclosing_tags;
 702
 703             my $replaceby = join( "\n", @lines );
 704             $letter->{content} =~ s/\Q$line\E/$replaceby/s;
 705         }
 706     }
 707
 708     $letter->{content} = _process_tt(
 709         {
 710             content => $letter->{content},
 711             tables  => $tables,
 712         }
 713     );
 714
 715     $letter->{content} =~ s/<<\S*>>//go; #remove any stragglers
 716
 717     return $letter;
 718 }
 719
 720 sub _substitute_tables {
 721     my ( $letter, $tables ) = @_;
 722     while ( my ($table, $param) = each %$tables ) {
 723         next unless $param;
 724
 725         my $ref = ref $param;
 726
 727         my $values;
 728         if ($ref && $ref eq 'HASH') {
 729             $values = $param;
 730         }
 731         else {
 732             my $sth = _parseletter_sth($table);
 733             unless ($sth) {
 734                 warn "_parseletter_sth('$table') failed to return a valid sth.  No substitution will be done for that table.";
 735                 return;
 736             }
 737             $sth->execute( $ref ? @$param : $param );
 738
 739             $values = $sth->fetchrow_hashref;
 740             $sth->finish();
 741         }
 742
 743         _parseletter ( $letter, $table, $values );
 744     }
 745 }
 746
 747 sub _parseletter_sth {
 748     my $table = shift;
 749     my $sth;
 750     unless ($table) {
 751         carp "ERROR: _parseletter_sth() called without argument (table)";
 752         return;
 753     }
 754     # NOTE: we used to check whether we had a statement handle cached in
 755     #       a %handles module-level variable. This was a dumb move and
 756     #       broke things for the rest of us. prepare_cached is a better
 757     #       way to cache statement handles anyway.
 758     my $query =
 759     ($table eq 'biblio'       ) ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 760     ($table eq 'biblioitems'  ) ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 761     ($table eq 'items'        ) ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 762     ($table eq 'issues'       ) ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 763     ($table eq 'old_issues'   ) ? "SELECT * FROM $table WHERE     itemnumber = ? ORDER BY timestamp DESC LIMIT 1"  :
 764     ($table eq 'reserves'     ) ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?"             :
 765     ($table eq 'borrowers'    ) ? "SELECT * FROM $table WHERE borrowernumber = ?"                                  :
 766     ($table eq 'branches'     ) ? "SELECT * FROM $table WHERE     branchcode = ?"                                  :
 767     ($table eq 'suggestions'  ) ? "SELECT * FROM $table WHERE   suggestionid = ?"                                  :
 768     ($table eq 'aqbooksellers') ? "SELECT * FROM $table WHERE             id = ?"                                  :
 769     ($table eq 'aqorders'     ) ? "SELECT * FROM $table WHERE    ordernumber = ?"                                  :
 770     ($table eq 'opac_news'    ) ? "SELECT * FROM $table WHERE          idnew = ?"                                  :
 771     ($table eq 'borrower_modifications') ? "SELECT * FROM $table WHERE verification_token = ?" :
 772     ($table eq 'subscription') ? "SELECT * FROM $table WHERE subscriptionid = ?" :
 773     ($table eq 'serial') ? "SELECT * FROM $table WHERE serialid = ?" :
 774     undef ;
 775     unless ($query) {
 776         warn "ERROR: No _parseletter_sth query for table '$table'";
 777         return;     # nothing to get
 778     }
 779     unless ($sth = C4::Context->dbh->prepare_cached($query)) {
 780         warn "ERROR: Failed to prepare query: '$query'";
 781         return;
 782     }
 783     return $sth;    # now cache is populated for that $table
 784 }
 785
 786 =head2 _parseletter($letter, $table, $values)
 787
 788     parameters :
 789     - $letter : a hash to letter fields (title & content useful)
 790     - $table : the Koha table to parse.
 791     - $values_in : table record hashref
 792     parse all fields from a table, and replace values in title & content with the appropriate value
 793     (not exported sub, used only internally)
 794
 795 =cut
 796
 797 sub _parseletter {
 798     my ( $letter, $table, $values_in ) = @_;
 799
 800     # Work on a local copy of $values_in (passed by reference) to avoid side effects
 801     # in callers ( by changing / formatting values )
 802     my $values = $values_in ? { %$values_in } : {};
 803
 804     if ( $table eq 'borrowers' && $values->{'dateexpiry'} ){
 805         $values->{'dateexpiry'} = format_sqldatetime( $values->{'dateexpiry'} );
 806     }
 807
 808     if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
 809         my @waitingdate = split /-/, $values->{'waitingdate'};
 810
 811         $values->{'expirationdate'} = '';
 812         if ( C4::Context->preference('ReservesMaxPickUpDelay') ) {
 813             my $dt = dt_from_string();
 814             $dt->add( days => C4::Context->preference('ReservesMaxPickUpDelay') );
 815             $values->{'expirationdate'} = output_pref( { dt => $dt, dateonly => 1 } );
 816         }
 817
 818         $values->{'waitingdate'} = output_pref({ dt => dt_from_string( $values->{'waitingdate'} ), dateonly => 1 });
 819
 820     }
 821
 822     if ($letter->{content} && $letter->{content} =~ /<<today>>/) {
 823         my $todaysdate = output_pref( DateTime->now() );
 824         $letter->{content} =~ s/<<today>>/$todaysdate/go;
 825     }
 826
 827     while ( my ($field, $val) = each %$values ) {
 828         $val =~ s/\p{P}$// if $val && $table=~/biblio/;
 829             #BZ 9886: Assuming that we want to eliminate ISBD punctuation here
 830             #Therefore adding the test on biblio. This includes biblioitems,
 831             #but excludes items. Removed unneeded global and lookahead.
 832
 833         $val = GetAuthorisedValueByCode ('ROADTYPE', $val, 0) if $table=~/^borrowers$/ && $field=~/^streettype$/;
 834
 835         # Dates replacement
 836         my $replacedby   = defined ($val) ? $val : '';
 837         if (    $replacedby
 838             and not $replacedby =~ m|0000-00-00|
 839             and not $replacedby =~ m|9999-12-31|
 840             and $replacedby =~ m|^\d{4}-\d{2}-\d{2}( \d{2}:\d{2}:\d{2})?$| )
 841         {
 842             # If the value is XXXX-YY-ZZ[ AA:BB:CC] we assume it is a date
 843             my $dateonly = defined $1 ? 0 : 1; #$1 refers to the capture group wrapped in parentheses. In this case, that's the hours, minutes, seconds.
 844             my $re_dateonly_filter = qr{ $field( \s* \| \s* dateonly\s*)?>> }xms;
 845
 846             for my $letter_field ( qw( title content ) ) {
 847                 my $filter_string_used = q{};
 848                 if ( $letter->{ $letter_field } =~ $re_dateonly_filter ) {
 849                     # We overwrite $dateonly if the filter exists and we have a time in the datetime
 850                     $filter_string_used = $1 || q{};
 851                     $dateonly = $1 unless $dateonly;
 852                 }
 853                 my $replacedby_date = eval {
 854                     output_pref({ dt => dt_from_string( $replacedby ), dateonly => $dateonly });
 855                 };
 856
 857                 if ( $letter->{ $letter_field } ) {
 858                     $letter->{ $letter_field } =~ s/\Q<<$table.$field$filter_string_used>>\E/$replacedby_date/g;
 859                     $letter->{ $letter_field } =~ s/\Q<<$field$filter_string_used>>\E/$replacedby_date/g;
 860                 }
 861             }
 862         }
 863         # Other fields replacement
 864         else {
 865             for my $letter_field ( qw( title content ) ) {
 866                 if ( $letter->{ $letter_field } ) {
 867                     $letter->{ $letter_field }   =~ s/<<$table.$field>>/$replacedby/g;
 868                     $letter->{ $letter_field }   =~ s/<<$field>>/$replacedby/g;
 869                 }
 870             }
 871         }
 872     }
 873
 874     if ($table eq 'borrowers' && $letter->{content}) {
 875         if ( my $attributes = GetBorrowerAttributes($values->{borrowernumber}) ) {
 876             my %attr;
 877             foreach (@$attributes) {
 878                 my $code = $_->{code};
 879                 my $val  = $_->{value_description} || $_->{value};
 880                 $val =~ s/\p{P}(?=$)//g if $val;
 881                 next unless $val gt '';
 882                 $attr{$code} ||= [];
 883                 push @{ $attr{$code} }, $val;
 884             }
 885             while ( my ($code, $val_ar) = each %attr ) {
 886                 my $replacefield = "<<borrower-attribute:$code>>";
 887                 my $replacedby   = join ',', @$val_ar;
 888                 $letter->{content} =~ s/$replacefield/$replacedby/g;
 889             }
 890         }
 891     }
 892     return $letter;
 893 }
 894
 895 =head2 EnqueueLetter
 896
 897   my $success = EnqueueLetter( { letter => $letter,
 898         borrowernumber => '12', message_transport_type => 'email' } )
 899
 900 places a letter in the message_queue database table, which will
 901 eventually get processed (sent) by the process_message_queue.pl
 902 cronjob when it calls SendQueuedMessages.
 903
 904 return message_id on success
 905
 906 =cut
 907
 908 sub EnqueueLetter {
 909     my $params = shift or return;
 910
 911     return unless exists $params->{'letter'};
 912 #   return unless exists $params->{'borrowernumber'};
 913     return unless exists $params->{'message_transport_type'};
 914
 915     my $content = $params->{letter}->{content};
 916     $content =~ s/\s+//g if(defined $content);
 917     if ( not defined $content or $content eq '' ) {
 918         warn "Trying to add an empty message to the message queue" if $debug;
 919         return;
 920     }
 921
 922     # If we have any attachments we should encode then into the body.
 923     if ( $params->{'attachments'} ) {
 924         $params->{'letter'} = _add_attachments(
 925             {   letter      => $params->{'letter'},
 926                 attachments => $params->{'attachments'},
 927                 message     => MIME::Lite->new( Type => 'multipart/mixed' ),
 928             }
 929         );
 930     }
 931
 932     my $dbh       = C4::Context->dbh();
 933     my $statement = << 'ENDSQL';
 934 INSERT INTO message_queue
 935 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type )
 936 VALUES
 937 ( ?,              ?,       ?,       ?,        ?,           ?,                      ?,      NOW(),       ?,          ?,            ? )
 938 ENDSQL
 939
 940     my $sth    = $dbh->prepare($statement);
 941     my $result = $sth->execute(
 942         $params->{'borrowernumber'},              # borrowernumber
 943         $params->{'letter'}->{'title'},           # subject
 944         $params->{'letter'}->{'content'},         # content
 945         $params->{'letter'}->{'metadata'} || '',  # metadata
 946         $params->{'letter'}->{'code'}     || '',  # letter_code
 947         $params->{'message_transport_type'},      # message_transport_type
 948         'pending',                                # status
 949         $params->{'to_address'},                  # to_address
 950         $params->{'from_address'},                # from_address
 951         $params->{'letter'}->{'content-type'},    # content_type
 952     );
 953     return $dbh->last_insert_id(undef,undef,'message_queue', undef);
 954 }
 955
 956 =head2 SendQueuedMessages ([$hashref])
 957
 958   my $sent = SendQueuedMessages( { verbose => 1 } );
 959
 960 sends all of the 'pending' items in the message queue.
 961
 962 returns number of messages sent.
 963
 964 =cut
 965
 966 sub SendQueuedMessages {
 967     my $params = shift;
 968
 969     my $unsent_messages = _get_unsent_messages();
 970     MESSAGE: foreach my $message ( @$unsent_messages ) {
 971         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
 972         warn sprintf( 'sending %s message to patron: %s',
 973                       $message->{'message_transport_type'},
 974                       $message->{'borrowernumber'} || 'Admin' )
 975           if $params->{'verbose'} or $debug;
 976         # This is just begging for subclassing
 977         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
 978         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
 979             _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
 980         }
 981         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
 982             if ( C4::Context->preference('SMSSendDriver') eq 'Email' ) {
 983                 my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
 984                 my $sms_provider = Koha::SMS::Providers->find( $member->{'sms_provider_id'} );
 985                 $message->{to_address} .= '@' . $sms_provider->domain();
 986                 _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
 987             } else {
 988                 _send_message_by_sms( $message );
 989             }
 990         }
 991     }
 992     return scalar( @$unsent_messages );
 993 }
 994
 995 =head2 GetRSSMessages
 996
 997   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
 998
 999 returns a listref of all queued RSS messages for a particular person.
1000
1001 =cut
1002
1003 sub GetRSSMessages {
1004     my $params = shift;
1005
1006     return unless $params;
1007     return unless ref $params;
1008     return unless $params->{'borrowernumber'};
1009
1010     return _get_unsent_messages( { message_transport_type => 'rss',
1011                                    limit                  => $params->{'limit'},
1012                                    borrowernumber         => $params->{'borrowernumber'}, } );
1013 }
1014
1015 =head2 GetPrintMessages
1016
1017   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
1018
1019 Returns a arrayref of all queued print messages (optionally, for a particular
1020 person).
1021
1022 =cut
1023
1024 sub GetPrintMessages {
1025     my $params = shift || {};
1026
1027     return _get_unsent_messages( { message_transport_type => 'print',
1028                                    borrowernumber         => $params->{'borrowernumber'},
1029                                  } );
1030 }
1031
1032 =head2 GetQueuedMessages ([$hashref])
1033
1034   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
1035
1036 fetches messages out of the message queue.
1037
1038 returns:
1039 list of hashes, each has represents a message in the message queue.
1040
1041 =cut
1042
1043 sub GetQueuedMessages {
1044     my $params = shift;
1045
1046     my $dbh = C4::Context->dbh();
1047     my $statement = << 'ENDSQL';
1048 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued
1049 FROM message_queue
1050 ENDSQL
1051
1052     my @query_params;
1053     my @whereclauses;
1054     if ( exists $params->{'borrowernumber'} ) {
1055         push @whereclauses, ' borrowernumber = ? ';
1056         push @query_params, $params->{'borrowernumber'};
1057     }
1058
1059     if ( @whereclauses ) {
1060         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
1061     }
1062
1063     if ( defined $params->{'limit'} ) {
1064         $statement .= ' LIMIT ? ';
1065         push @query_params, $params->{'limit'};
1066     }
1067
1068     my $sth = $dbh->prepare( $statement );
1069     my $result = $sth->execute( @query_params );
1070     return $sth->fetchall_arrayref({});
1071 }
1072
1073 =head2 GetMessageTransportTypes
1074
1075   my @mtt = GetMessageTransportTypes();
1076
1077   returns an arrayref of transport types
1078
1079 =cut
1080
1081 sub GetMessageTransportTypes {
1082     my $dbh = C4::Context->dbh();
1083     my $mtts = $dbh->selectcol_arrayref("
1084         SELECT message_transport_type
1085         FROM message_transport_types
1086         ORDER BY message_transport_type
1087     ");
1088     return $mtts;
1089 }
1090
1091 =head2 GetMessage
1092
1093     my $message = C4::Letters::Message($message_id);
1094
1095 =cut
1096
1097 sub GetMessage {
1098     my ( $message_id ) = @_;
1099     return unless $message_id;
1100     my $dbh = C4::Context->dbh;
1101     return $dbh->selectrow_hashref(q|
1102         SELECT message_id, borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type
1103         FROM message_queue
1104         WHERE message_id = ?
1105     |, {}, $message_id );
1106 }
1107
1108 =head2 ResendMessage
1109
1110   Attempt to resend a message which has failed previously.
1111
1112   my $has_been_resent = C4::Letters::ResendMessage($message_id);
1113
1114   Updates the message to 'pending' status so that
1115   it will be resent later on.
1116
1117   returns 1 on success, 0 on failure, undef if no message was found
1118
1119 =cut
1120
1121 sub ResendMessage {
1122     my $message_id = shift;
1123     return unless $message_id;
1124
1125     my $message = GetMessage( $message_id );
1126     return unless $message;
1127     my $rv = 0;
1128     if ( $message->{status} ne 'pending' ) {
1129         $rv = C4::Letters::_set_message_status({
1130             message_id => $message_id,
1131             status => 'pending',
1132         });
1133         $rv = $rv > 0? 1: 0;
1134         # Clear destination email address to force address update
1135         _update_message_to_address( $message_id, undef ) if $rv &&
1136             $message->{message_transport_type} eq 'email';
1137     }
1138     return $rv;
1139 }
1140
1141 =head2 _add_attachements
1142
1143 named parameters:
1144 letter - the standard letter hashref
1145 attachments - listref of attachments. each attachment is a hashref of:
1146   type - the mime type, like 'text/plain'
1147   content - the actual attachment
1148   filename - the name of the attachment.
1149 message - a MIME::Lite object to attach these to.
1150
1151 returns your letter object, with the content updated.
1152
1153 =cut
1154
1155 sub _add_attachments {
1156     my $params = shift;
1157
1158     my $letter = $params->{'letter'};
1159     my $attachments = $params->{'attachments'};
1160     return $letter unless @$attachments;
1161     my $message = $params->{'message'};
1162
1163     # First, we have to put the body in as the first attachment
1164     $message->attach(
1165         Type => $letter->{'content-type'} || 'TEXT',
1166         Data => $letter->{'is_html'}
1167             ? _wrap_html($letter->{'content'}, $letter->{'title'})
1168             : $letter->{'content'},
1169     );
1170
1171     foreach my $attachment ( @$attachments ) {
1172         $message->attach(
1173             Type     => $attachment->{'type'},
1174             Data     => $attachment->{'content'},
1175             Filename => $attachment->{'filename'},
1176         );
1177     }
1178     # we're forcing list context here to get the header, not the count back from grep.
1179     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
1180     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
1181     $letter->{'content'} = $message->body_as_string;
1182
1183     return $letter;
1184
1185 }
1186
1187 sub _get_unsent_messages {
1188     my $params = shift;
1189
1190     my $dbh = C4::Context->dbh();
1191     my $statement = << 'ENDSQL';
1192 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
1193   FROM message_queue mq
1194   LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
1195  WHERE status = ?
1196 ENDSQL
1197
1198     my @query_params = ('pending');
1199     if ( ref $params ) {
1200         if ( $params->{'message_transport_type'} ) {
1201             $statement .= ' AND message_transport_type = ? ';
1202             push @query_params, $params->{'message_transport_type'};
1203         }
1204         if ( $params->{'borrowernumber'} ) {
1205             $statement .= ' AND borrowernumber = ? ';
1206             push @query_params, $params->{'borrowernumber'};
1207         }
1208         if ( $params->{'limit'} ) {
1209             $statement .= ' limit ? ';
1210             push @query_params, $params->{'limit'};
1211         }
1212     }
1213
1214     $debug and warn "_get_unsent_messages SQL: $statement";
1215     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
1216     my $sth = $dbh->prepare( $statement );
1217     my $result = $sth->execute( @query_params );
1218     return $sth->fetchall_arrayref({});
1219 }
1220
1221 sub _send_message_by_email {
1222     my $message = shift or return;
1223     my ($username, $password, $method) = @_;
1224
1225     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
1226     my $to_address = $message->{'to_address'};
1227     unless ($to_address) {
1228         unless ($member) {
1229             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
1230             _set_message_status( { message_id => $message->{'message_id'},
1231                                    status     => 'failed' } );
1232             return;
1233         }
1234         $to_address = C4::Members::GetNoticeEmailAddress( $message->{'borrowernumber'} );
1235         unless ($to_address) {
1236             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
1237             # warning too verbose for this more common case?
1238             _set_message_status( { message_id => $message->{'message_id'},
1239                                    status     => 'failed' } );
1240             return;
1241         }
1242     }
1243
1244     my $utf8   = decode('MIME-Header', $message->{'subject'} );
1245     $message->{subject}= encode('MIME-Header', $utf8);
1246     my $subject = encode('UTF-8', $message->{'subject'});
1247     my $content = encode('UTF-8', $message->{'content'});
1248     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
1249     my $is_html = $content_type =~ m/html/io;
1250     my $branch_email = undef;
1251     my $branch_replyto = undef;
1252     my $branch_returnpath = undef;
1253     if ($member) {
1254         my $library = Koha::Libraries->find( $member->{branchcode} );
1255         $branch_email      = $library->branchemail;
1256         $branch_replyto    = $library->branchreplyto;
1257         $branch_returnpath = $library->branchreturnpath;
1258     }
1259     my $email = Koha::Email->new();
1260     my %sendmail_params = $email->create_message_headers(
1261         {
1262             to      => $to_address,
1263             from    => $message->{'from_address'} || $branch_email,
1264             replyto => $branch_replyto,
1265             sender  => $branch_returnpath,
1266             subject => $subject,
1267             message => $is_html ? _wrap_html( $content, $subject ) : $content,
1268             contenttype => $content_type
1269         }
1270     );
1271
1272     $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
1273     if ( my $bcc = C4::Context->preference('OverdueNoticeBcc') ) {
1274        $sendmail_params{ Bcc } = $bcc;
1275     }
1276
1277     _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
1278
1279     if ( sendmail( %sendmail_params ) ) {
1280         _set_message_status( { message_id => $message->{'message_id'},
1281                 status     => 'sent' } );
1282         return 1;
1283     } else {
1284         _set_message_status( { message_id => $message->{'message_id'},
1285                 status     => 'failed' } );
1286         carp $Mail::Sendmail::error;
1287         return;
1288     }
1289 }
1290
1291 sub _wrap_html {
1292     my ($content, $title) = @_;
1293
1294     my $css = C4::Context->preference("NoticeCSS") || '';
1295     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
1296     return <<EOS;
1297 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1298     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1299 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1300 <head>
1301 <title>$title</title>
1302 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1303 $css
1304 </head>
1305 <body>
1306 $content
1307 </body>
1308 </html>
1309 EOS
1310 }
1311
1312 sub _is_duplicate {
1313     my ( $message ) = @_;
1314     my $dbh = C4::Context->dbh;
1315     my $count = $dbh->selectrow_array(q|
1316         SELECT COUNT(*)
1317         FROM message_queue
1318         WHERE message_transport_type = ?
1319         AND borrowernumber = ?
1320         AND letter_code = ?
1321         AND CAST(time_queued AS date) = CAST(NOW() AS date)
1322         AND status="sent"
1323         AND content = ?
1324     |, {}, $message->{message_transport_type}, $message->{borrowernumber}, $message->{letter_code}, $message->{content} );
1325     return $count;
1326 }
1327
1328 sub _send_message_by_sms {
1329     my $message = shift or return;
1330     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
1331
1332     unless ( $member->{smsalertnumber} ) {
1333         _set_message_status( { message_id => $message->{'message_id'},
1334                                status     => 'failed' } );
1335         return;
1336     }
1337
1338     if ( _is_duplicate( $message ) ) {
1339         _set_message_status( { message_id => $message->{'message_id'},
1340                                status     => 'failed' } );
1341         return;
1342     }
1343
1344     my $success = C4::SMS->send_sms( { destination => $member->{'smsalertnumber'},
1345                                        message     => $message->{'content'},
1346                                      } );
1347     _set_message_status( { message_id => $message->{'message_id'},
1348                            status     => ($success ? 'sent' : 'failed') } );
1349     return $success;
1350 }
1351
1352 sub _update_message_to_address {
1353     my ($id, $to)= @_;
1354     my $dbh = C4::Context->dbh();
1355     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1356 }
1357
1358 sub _set_message_status {
1359     my $params = shift or return;
1360
1361     foreach my $required_parameter ( qw( message_id status ) ) {
1362         return unless exists $params->{ $required_parameter };
1363     }
1364
1365     my $dbh = C4::Context->dbh();
1366     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1367     my $sth = $dbh->prepare( $statement );
1368     my $result = $sth->execute( $params->{'status'},
1369                                 $params->{'message_id'} );
1370     return $result;
1371 }
1372
1373 sub _process_tt {
1374     my ( $params ) = @_;
1375
1376     my $content = $params->{content};
1377     my $tables = $params->{tables};
1378
1379     my $use_template_cache = C4::Context->config('template_cache_dir') && defined $ENV{GATEWAY_INTERFACE};
1380     my $template           = Template->new(
1381         {
1382             EVAL_PERL    => 1,
1383             ABSOLUTE     => 1,
1384             PLUGIN_BASE  => 'Koha::Template::Plugin',
1385             COMPILE_EXT  => $use_template_cache ? '.ttc' : '',
1386             COMPILE_DIR  => $use_template_cache ? C4::Context->config('template_cache_dir') : '',
1387             FILTERS      => {},
1388             ENCODING     => 'UTF-8',
1389         }
1390     ) or die Template->error();
1391
1392     my $tt_params = _get_tt_params( $tables );
1393
1394     my $output;
1395     $template->process( \$content, $tt_params, \$output ) || croak "ERROR PROCESSING TEMPLATE: " . $template->error();
1396
1397     return $output;
1398 }
1399
1400 sub _get_tt_params {
1401     my ($tables) = @_;
1402
1403     my $params;
1404
1405     my $config = {
1406         biblio => {
1407             module   => 'Koha::Biblios',
1408             singular => 'biblio',
1409             plural   => 'biblios',
1410             pk       => 'biblionumber',
1411         },
1412         borrowers => {
1413             module   => 'Koha::Patrons',
1414             singular => 'borrower',
1415             plural   => 'borrowers',
1416             pk       => 'borrowernumber',
1417         },
1418         branches => {
1419             module   => 'Koha::Libraries',
1420             singular => 'branch',
1421             plural   => 'branches',
1422             pk       => 'branchcode',
1423         },
1424         items => {
1425             module   => 'Koha::Items',
1426             singular => 'item',
1427             plural   => 'items',
1428             pk       => 'itemnumber',
1429         },
1430         opac_news => {
1431             module   => 'Koha::News',
1432             singular => 'news',
1433             plural   => 'news',
1434             pk       => 'idnew',
1435         },
1436         reserves => {
1437             module   => 'Koha::Holds',
1438             singular => 'hold',
1439             plural   => 'holds',
1440             fk       => [ 'borrowernumber', 'biblionumber' ],
1441         },
1442         serial => {
1443             module   => 'Koha::Serials',
1444             singular => 'serial',
1445             plural   => 'serials',
1446             pk       => 'serialid',
1447         },
1448         subscription => {
1449             module   => 'Koha::Subscriptions',
1450             singular => 'subscription',
1451             plural   => 'subscriptions',
1452             pk       => 'subscriptionid',
1453         },
1454         suggestions => {
1455             module   => 'Koha::Suggestions',
1456             singular => 'suggestion',
1457             plural   => 'suggestions',
1458             pk       => 'suggestionid',
1459         },
1460         issues => {
1461             module   => 'Koha::Checkouts',
1462             singular => 'checkout',
1463             plural   => 'checkouts',
1464             fk       => 'itemnumber',
1465         },
1466         borrower_modifications => {
1467             module   => 'Koha::Patron::Modifications',
1468             singular => 'patron_modification',
1469             plural   => 'patron_modifications',
1470             fk       => 'verification_token',
1471         },
1472     };
1473
1474     foreach my $table ( keys %$tables ) {
1475         next unless $config->{$table};
1476
1477         my $ref = ref( $tables->{$table} ) || q{};
1478         my $module = $config->{$table}->{module};
1479
1480         if ( can_load( modules => { $module => undef } ) ) {
1481             my $pk = $config->{$table}->{pk};
1482             my $fk = $config->{$table}->{fk};
1483
1484             if ( $ref eq q{} || $ref eq 'HASH' ) {
1485                 my $id = ref $ref eq 'HASH' ? $tables->{$table}->{$pk} : $tables->{$table};
1486                 my $object;
1487                 if ( $fk ) { # Using a foreign key for lookup
1488                     if ( ref( $fk ) eq 'ARRAY' ) { # Foreign key is multi-column
1489                         my $search;
1490                         foreach my $key ( @$fk ) {
1491                             $search->{$key} = $id->{$key};
1492                         }
1493                         $object = $module->search( $search )->next();
1494                     } else { # Foreign key is single column
1495                         $object = $module->search( { $fk => $id } )->next();
1496                     }
1497                 } else { # using the table's primary key for lookup
1498                     $object = $module->find($id);
1499                 }
1500                 $params->{ $config->{$table}->{singular} } = $object;
1501             }
1502             else {    # $ref eq 'ARRAY'
1503                 my $object;
1504                 if ( @{ $tables->{$table} } == 1 ) {    # Param is a single key
1505                     $object = $module->search( { $pk => $tables->{$table} } )->next();
1506                 }
1507                 else {                                  # Params are mutliple foreign keys
1508                     my @values = @{ $tables->{$table} };
1509                     my @keys   = @{ $config->{$table}->{fk} };
1510                     my %params = map { $_ => shift(@values) } @keys;
1511                     $object = $module->search( \%params )->next();
1512                 }
1513                 $params->{ $config->{$table}->{singular} } = $object;
1514             }
1515         }
1516         else {
1517             croak "ERROR LOADING MODULE $module: $Module::Load::Conditional::ERROR";
1518         }
1519     }
1520
1521     $params->{today} = dt_from_string();
1522
1523     return $params;
1524 }
1525
1526
1527 1;
1528 __END__