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