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