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