C4/Letters.pm

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