C4/Letters.pm

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