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 Modern::Perl;
  21
  22 use MIME::Lite;
  23 use Mail::Sendmail;
  24 use Date::Calc qw( Add_Delta_Days );
  25 use Encode;
  26 use Carp;
  27 use Template;
  28 use Module::Load::Conditional qw(can_load);
  29
  30 use C4::Members;
  31 use C4::Members::Attributes qw(GetBorrowerAttributes);
  32 use C4::Log;
  33 use C4::SMS;
  34 use C4::Debug;
  35 use Koha::DateUtils;
  36 use Koha::SMS::Providers;
  37
  38 use Koha::Email;
  39 use Koha::DateUtils qw( format_sqldatetime dt_from_string );
  40 use Koha::Patrons;
  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   DEPRECATED - You must use Koha::Notice::Templates instead
  74   The group by clause is confusing and can lead to issues
  75
  76 =cut
  77
  78 sub GetLetters {
  79     my ($filters) = @_;
  80     my $module    = $filters->{module};
  81     my $code      = $filters->{code};
  82     my $branchcode = $filters->{branchcode};
  83     my $dbh       = C4::Context->dbh;
  84     my $letters   = $dbh->selectall_arrayref(
  85         q|
  86             SELECT code, module, name
  87             FROM letter
  88             WHERE 1
  89         |
  90           . ( $module ? q| AND module = ?| : q|| )
  91           . ( $code   ? q| AND code = ?|   : q|| )
  92           . ( defined $branchcode   ? q| AND branchcode = ?|   : q|| )
  93           . q| GROUP BY code, module, name ORDER BY name|, { Slice => {} }
  94         , ( $module ? $module : () )
  95         , ( $code ? $code : () )
  96         , ( defined $branchcode ? $branchcode : () )
  97     );
  98
  99     return $letters;
 100 }
 101
 102 =head2 GetLetterTemplates
 103
 104     my $letter_templates = GetLetterTemplates(
 105         {
 106             module => 'circulation',
 107             code => 'my code',
 108             branchcode => 'CPL', # '' for default,
 109         }
 110     );
 111
 112     Return a hashref of letter templates.
 113
 114 =cut
 115
 116 sub GetLetterTemplates {
 117     my ( $params ) = @_;
 118
 119     my $module    = $params->{module};
 120     my $code      = $params->{code};
 121     my $branchcode = $params->{branchcode} // '';
 122     my $dbh       = C4::Context->dbh;
 123     my $letters   = $dbh->selectall_arrayref(
 124         q|
 125             SELECT module, code, branchcode, name, is_html, title, content, message_transport_type, lang
 126             FROM letter
 127             WHERE module = ?
 128             AND code = ?
 129             and branchcode = ?
 130         |
 131         , { Slice => {} }
 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, $lang) = @_;
 206     $message_transport_type //= '%';
 207     $lang = 'default' unless( $lang && C4::Context->preference('TranslateNotices') );
 208
 209
 210     my $only_my_library = C4::Context->only_my_library;
 211     if ( $only_my_library and $branchcode ) {
 212         $branchcode = C4::Context::mybranch();
 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         AND lang =?
 223         ORDER BY branchcode DESC LIMIT 1
 224     });
 225     $sth->execute( $module, $code, $branchcode, $message_transport_type, $lang );
 226     my $line = $sth->fetchrow_hashref
 227       or return;
 228     $line->{'content-type'} = 'text/html; charset="UTF-8"' if $line->{is_html};
 229     return { %$line };
 230 }
 231
 232
 233 =head2 DelLetter
 234
 235     DelLetter(
 236         {
 237             branchcode => 'CPL',
 238             module => 'circulation',
 239             code => 'my code',
 240             [ mtt => 'email', ]
 241         }
 242     );
 243
 244     Delete the letter. The mtt parameter is facultative.
 245     If not given, all templates mathing the other parameters will be removed.
 246
 247 =cut
 248
 249 sub DelLetter {
 250     my ($params)   = @_;
 251     my $branchcode = $params->{branchcode};
 252     my $module     = $params->{module};
 253     my $code       = $params->{code};
 254     my $mtt        = $params->{mtt};
 255     my $lang       = $params->{lang};
 256     my $dbh        = C4::Context->dbh;
 257     $dbh->do(q|
 258         DELETE FROM letter
 259         WHERE branchcode = ?
 260           AND module = ?
 261           AND code = ?
 262     |
 263     . ( $mtt ? q| AND message_transport_type = ?| : q|| )
 264     . ( $lang? q| AND lang = ?| : q|| )
 265     , undef, $branchcode, $module, $code, ( $mtt ? $mtt : () ), ( $lang ? $lang : () ) );
 266 }
 267
 268 =head2 addalert ($borrowernumber, $type, $externalid)
 269
 270     parameters :
 271     - $borrowernumber : the number of the borrower subscribing to the alert
 272     - $type : the type of alert.
 273     - $externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid.
 274
 275     create an alert and return the alertid (primary key)
 276
 277 =cut
 278
 279 sub addalert {
 280     my ( $borrowernumber, $type, $externalid ) = @_;
 281     my $dbh = C4::Context->dbh;
 282     my $sth =
 283       $dbh->prepare(
 284         "insert into alert (borrowernumber, type, externalid) values (?,?,?)");
 285     $sth->execute( $borrowernumber, $type, $externalid );
 286
 287     # get the alert number newly created and return it
 288     my $alertid = $dbh->{'mysql_insertid'};
 289     return $alertid;
 290 }
 291
 292 =head2 delalert ($alertid)
 293
 294     parameters :
 295     - alertid : the alert id
 296     deletes the alert
 297
 298 =cut
 299
 300 sub delalert {
 301     my $alertid = shift or die "delalert() called without valid argument (alertid)";    # it's gonna die anyway.
 302     $debug and warn "delalert: deleting alertid $alertid";
 303     my $sth = C4::Context->dbh->prepare("delete from alert where alertid=?");
 304     $sth->execute($alertid);
 305 }
 306
 307 =head2 getalert ([$borrowernumber], [$type], [$externalid])
 308
 309     parameters :
 310     - $borrowernumber : the number of the borrower subscribing to the alert
 311     - $type : the type of alert.
 312     - $externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid.
 313     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.
 314
 315 =cut
 316
 317 sub getalert {
 318     my ( $borrowernumber, $type, $externalid ) = @_;
 319     my $dbh   = C4::Context->dbh;
 320     my $query = "SELECT a.*, b.branchcode FROM alert a JOIN borrowers b USING(borrowernumber) WHERE 1";
 321     my @bind;
 322     if ($borrowernumber and $borrowernumber =~ /^\d+$/) {
 323         $query .= " AND borrowernumber=?";
 324         push @bind, $borrowernumber;
 325     }
 326     if ($type) {
 327         $query .= " AND type=?";
 328         push @bind, $type;
 329     }
 330     if ($externalid) {
 331         $query .= " AND externalid=?";
 332         push @bind, $externalid;
 333     }
 334     my $sth = $dbh->prepare($query);
 335     $sth->execute(@bind);
 336     return $sth->fetchall_arrayref({});
 337 }
 338
 339 =head2 findrelatedto($type, $externalid)
 340
 341     parameters :
 342     - $type : the type of alert
 343     - $externalid : the id of the "object" to query
 344
 345     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.
 346     When type=issue, the id is related to a subscriptionid and this sub returns the name of the biblio.
 347
 348 =cut
 349
 350 # outmoded POD:
 351 # When type=virtual, the id is related to a virtual shelf and this sub returns the name of the sub
 352
 353 sub findrelatedto {
 354     my $type       = shift or return;
 355     my $externalid = shift or return;
 356     my $q = ($type eq 'issue'   ) ?
 357 "select title as result from subscription left join biblio on subscription.biblionumber=biblio.biblionumber where subscriptionid=?" :
 358             ($type eq 'borrower') ?
 359 "select concat(firstname,' ',surname) from borrowers where borrowernumber=?" : undef;
 360     unless ($q) {
 361         warn "findrelatedto(): Illegal type '$type'";
 362         return;
 363     }
 364     my $sth = C4::Context->dbh->prepare($q);
 365     $sth->execute($externalid);
 366     my ($result) = $sth->fetchrow;
 367     return $result;
 368 }
 369
 370 =head2 SendAlerts
 371
 372     my $err = &SendAlerts($type, $externalid, $letter_code);
 373
 374     Parameters:
 375       - $type : the type of alert
 376       - $externalid : the id of the "object" to query
 377       - $letter_code : the notice template to use
 378
 379     C<&SendAlerts> sends an email notice directly to a patron or a vendor.
 380
 381     Currently it supports ($type):
 382       - claim serial issues (claimissues)
 383       - claim acquisition orders (claimacquisition)
 384       - send acquisition orders to the vendor (orderacquisition)
 385       - notify patrons about newly received serial issues (issue)
 386       - notify patrons when their account is created (members)
 387
 388     Returns undef or { error => 'message } on failure.
 389     Returns true on success.
 390
 391 =cut
 392
 393 sub SendAlerts {
 394     my ( $type, $externalid, $letter_code ) = @_;
 395     my $dbh = C4::Context->dbh;
 396     if ( $type eq 'issue' ) {
 397
 398         # prepare the letter...
 399         # search the subscriptionid
 400         my $sth =
 401           $dbh->prepare(
 402             "SELECT subscriptionid FROM serial WHERE serialid=?");
 403         $sth->execute($externalid);
 404         my ($subscriptionid) = $sth->fetchrow
 405           or warn( "No subscription for '$externalid'" ),
 406              return;
 407
 408         # search the biblionumber
 409         $sth =
 410           $dbh->prepare(
 411             "SELECT biblionumber FROM subscription WHERE subscriptionid=?");
 412         $sth->execute($subscriptionid);
 413         my ($biblionumber) = $sth->fetchrow
 414           or warn( "No biblionumber for '$subscriptionid'" ),
 415              return;
 416
 417         my %letter;
 418         # find the list of borrowers to alert
 419         my $alerts = getalert( '', 'issue', $subscriptionid );
 420         foreach (@$alerts) {
 421             my $patron = Koha::Patrons->find( $_->{borrowernumber} );
 422             next unless $patron; # Just in case
 423             my $email = $patron->email or next;
 424
 425 #                    warn "sending issues...";
 426             my $userenv = C4::Context->userenv;
 427             my $library = Koha::Libraries->find( $_->{branchcode} );
 428             my $letter = GetPreparedLetter (
 429                 module => 'serial',
 430                 letter_code => $letter_code,
 431                 branchcode => $userenv->{branch},
 432                 tables => {
 433                     'branches'    => $_->{branchcode},
 434                     'biblio'      => $biblionumber,
 435                     'biblioitems' => $biblionumber,
 436                     'borrowers'   => $patron->unblessed,
 437                     'subscription' => $subscriptionid,
 438                     'serial' => $externalid,
 439                 },
 440                 want_librarian => 1,
 441             ) or return;
 442
 443             # ... then send mail
 444             my $message = Koha::Email->new();
 445             my %mail = $message->create_message_headers(
 446                 {
 447                     to      => $email,
 448                     from    => $library->branchemail,
 449                     replyto => $library->branchreplyto,
 450                     sender  => $library->branchreturnpath,
 451                     subject => Encode::encode( "UTF-8", "" . $letter->{title} ),
 452                     message => $letter->{'is_html'}
 453                                 ? _wrap_html( Encode::encode( "UTF-8", $letter->{'content'} ),
 454                                               Encode::encode( "UTF-8", "" . $letter->{'title'} ))
 455                                 : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
 456                     contenttype => $letter->{'is_html'}
 457                                     ? 'text/html; charset="utf-8"'
 458                                     : 'text/plain; charset="utf-8"',
 459                 }
 460             );
 461             unless( Mail::Sendmail::sendmail(%mail) ) {
 462                 carp $Mail::Sendmail::error;
 463                 return { error => $Mail::Sendmail::error };
 464             }
 465         }
 466     }
 467     elsif ( $type eq 'claimacquisition' or $type eq 'claimissues' or $type eq 'orderacquisition' ) {
 468
 469         # prepare the letter...
 470         my $strsth;
 471         my $sthorders;
 472         my $dataorders;
 473         my $action;
 474         if ( $type eq 'claimacquisition') {
 475             $strsth = qq{
 476             SELECT aqorders.*,aqbasket.*,biblio.*,biblioitems.*
 477             FROM aqorders
 478             LEFT JOIN aqbasket ON aqbasket.basketno=aqorders.basketno
 479             LEFT JOIN biblio ON aqorders.biblionumber=biblio.biblionumber
 480             LEFT JOIN biblioitems ON aqorders.biblionumber=biblioitems.biblionumber
 481             WHERE aqorders.ordernumber IN (
 482             };
 483
 484             if (!@$externalid){
 485                 carp "No order selected";
 486                 return { error => "no_order_selected" };
 487             }
 488             $strsth .= join( ",", ('?') x @$externalid ) . ")";
 489             $action = "ACQUISITION CLAIM";
 490             $sthorders = $dbh->prepare($strsth);
 491             $sthorders->execute( @$externalid );
 492             $dataorders = $sthorders->fetchall_arrayref( {} );
 493         }
 494
 495         if ($type eq 'claimissues') {
 496             $strsth = qq{
 497             SELECT serial.*,subscription.*, biblio.*, aqbooksellers.*,
 498             aqbooksellers.id AS booksellerid
 499             FROM serial
 500             LEFT JOIN subscription ON serial.subscriptionid=subscription.subscriptionid
 501             LEFT JOIN biblio ON serial.biblionumber=biblio.biblionumber
 502             LEFT JOIN aqbooksellers ON subscription.aqbooksellerid=aqbooksellers.id
 503             WHERE serial.serialid IN (
 504             };
 505
 506             if (!@$externalid){
 507                 carp "No Order selected";
 508                 return { error => "no_order_selected" };
 509             }
 510
 511             $strsth .= join( ",", ('?') x @$externalid ) . ")";
 512             $action = "CLAIM ISSUE";
 513             $sthorders = $dbh->prepare($strsth);
 514             $sthorders->execute( @$externalid );
 515             $dataorders = $sthorders->fetchall_arrayref( {} );
 516         }
 517
 518         if ( $type eq 'orderacquisition') {
 519             $strsth = qq{
 520             SELECT aqorders.*,aqbasket.*,biblio.*,biblioitems.*
 521             FROM aqorders
 522             LEFT JOIN aqbasket ON aqbasket.basketno=aqorders.basketno
 523             LEFT JOIN biblio ON aqorders.biblionumber=biblio.biblionumber
 524             LEFT JOIN biblioitems ON aqorders.biblionumber=biblioitems.biblionumber
 525             WHERE aqbasket.basketno = ?
 526             AND orderstatus IN ('new','ordered')
 527             };
 528
 529             if (!$externalid){
 530                 carp "No basketnumber given";
 531                 return { error => "no_basketno" };
 532             }
 533             $action = "ACQUISITION ORDER";
 534             $sthorders = $dbh->prepare($strsth);
 535             $sthorders->execute($externalid);
 536             $dataorders = $sthorders->fetchall_arrayref( {} );
 537         }
 538
 539         my $sthbookseller =
 540           $dbh->prepare("select * from aqbooksellers where id=?");
 541         $sthbookseller->execute( $dataorders->[0]->{booksellerid} );
 542         my $databookseller = $sthbookseller->fetchrow_hashref;
 543
 544         my $addressee =  $type eq 'claimacquisition' || $type eq 'orderacquisition' ? 'acqprimary' : 'serialsprimary';
 545
 546         my $sthcontact =
 547           $dbh->prepare("SELECT * FROM aqcontacts WHERE booksellerid=? AND $type=1 ORDER BY $addressee DESC");
 548         $sthcontact->execute( $dataorders->[0]->{booksellerid} );
 549         my $datacontact = $sthcontact->fetchrow_hashref;
 550
 551         my @email;
 552         my @cc;
 553         push @email, $databookseller->{bookselleremail} if $databookseller->{bookselleremail};
 554         push @email, $datacontact->{email}           if ( $datacontact && $datacontact->{email} );
 555         unless (@email) {
 556             warn "Bookseller $dataorders->[0]->{booksellerid} without emails";
 557             return { error => "no_email" };
 558         }
 559         my $addlcontact;
 560         while ($addlcontact = $sthcontact->fetchrow_hashref) {
 561             push @cc, $addlcontact->{email} if ( $addlcontact && $addlcontact->{email} );
 562         }
 563
 564         my $userenv = C4::Context->userenv;
 565         my $letter = GetPreparedLetter (
 566             module => $type,
 567             letter_code => $letter_code,
 568             branchcode => $userenv->{branch},
 569             tables => {
 570                 'branches'    => $userenv->{branch},
 571                 'aqbooksellers' => $databookseller,
 572                 'aqcontacts'    => $datacontact,
 573             },
 574             repeat => $dataorders,
 575             want_librarian => 1,
 576         ) or return { error => "no_letter" };
 577
 578         # Remove the order tag
 579         $letter->{content} =~ s/<order>(.*?)<\/order>/$1/gxms;
 580
 581         # ... then send mail
 582         my $library = Koha::Libraries->find( $userenv->{branch} );
 583         my %mail = (
 584             To => join( ',', @email),
 585             Cc             => join( ',', @cc),
 586             From           => $library->branchemail || C4::Context->preference('KohaAdminEmailAddress'),
 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             'Content-Type' => $letter->{'is_html'}
 593                                 ? 'text/html; charset="utf-8"'
 594                                 : 'text/plain; charset="utf-8"',
 595         );
 596
 597         if ($type eq 'claimacquisition' || $type eq 'claimissues' ) {
 598             $mail{'Reply-to'} = C4::Context->preference('ReplytoDefault')
 599               if C4::Context->preference('ReplytoDefault');
 600             $mail{'Sender'} = C4::Context->preference('ReturnpathDefault')
 601               if C4::Context->preference('ReturnpathDefault');
 602             $mail{'Bcc'} = $userenv->{emailaddress}
 603               if C4::Context->preference("ClaimsBccCopy");
 604         }
 605
 606         unless ( Mail::Sendmail::sendmail(%mail) ) {
 607             carp $Mail::Sendmail::error;
 608             return { error => $Mail::Sendmail::error };
 609         }
 610
 611         logaction(
 612             "ACQUISITION",
 613             $action,
 614             undef,
 615             "To="
 616                 . join( ',', @email )
 617                 . " Title="
 618                 . $letter->{title}
 619                 . " Content="
 620                 . $letter->{content}
 621         ) if C4::Context->preference("LetterLog");
 622     }
 623    # send an "account details" notice to a newly created user
 624     elsif ( $type eq 'members' ) {
 625         my $library = Koha::Libraries->find( $externalid->{branchcode} )->unblessed;
 626         my $letter = GetPreparedLetter (
 627             module => 'members',
 628             letter_code => $letter_code,
 629             branchcode => $externalid->{'branchcode'},
 630             tables => {
 631                 'branches'    => $library,
 632                 'borrowers' => $externalid->{'borrowernumber'},
 633             },
 634             substitute => { 'borrowers.password' => $externalid->{'password'} },
 635             want_librarian => 1,
 636         ) or return;
 637         return { error => "no_email" } unless $externalid->{'emailaddr'};
 638         my $email = Koha::Email->new();
 639         my %mail  = $email->create_message_headers(
 640             {
 641                 to      => $externalid->{'emailaddr'},
 642                 from    => $library->{branchemail},
 643                 replyto => $library->{branchreplyto},
 644                 sender  => $library->{branchreturnpath},
 645                 subject => Encode::encode( "UTF-8", "" . $letter->{'title'} ),
 646                 message => $letter->{'is_html'}
 647                             ? _wrap_html( Encode::encode( "UTF-8", $letter->{'content'} ),
 648                                           Encode::encode( "UTF-8", "" . $letter->{'title'}  ) )
 649                             : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
 650                 contenttype => $letter->{'is_html'}
 651                                 ? 'text/html; charset="utf-8"'
 652                                 : 'text/plain; charset="utf-8"',
 653             }
 654         );
 655         unless( Mail::Sendmail::sendmail(%mail) ) {
 656             carp $Mail::Sendmail::error;
 657             return { error => $Mail::Sendmail::error };
 658         }
 659     }
 660
 661     # If we come here, return an OK status
 662     return 1;
 663 }
 664
 665 =head2 GetPreparedLetter( %params )
 666
 667     %params hash:
 668       module => letter module, mandatory
 669       letter_code => letter code, mandatory
 670       branchcode => for letter selection, if missing default system letter taken
 671       tables => a hashref with table names as keys. Values are either:
 672         - a scalar - primary key value
 673         - an arrayref - primary key values
 674         - a hashref - full record
 675       substitute => custom substitution key/value pairs
 676       repeat => records to be substituted on consecutive lines:
 677         - an arrayref - tries to guess what needs substituting by
 678           taking remaining << >> tokensr; not recommended
 679         - a hashref token => @tables - replaces <token> << >> << >> </token>
 680           subtemplate for each @tables row; table is a hashref as above
 681       want_librarian => boolean,  if set to true triggers librarian details
 682         substitution from the userenv
 683     Return value:
 684       letter fields hashref (title & content useful)
 685
 686 =cut
 687
 688 sub GetPreparedLetter {
 689     my %params = @_;
 690
 691     my $letter = $params{letter};
 692
 693     unless ( $letter ) {
 694         my $module      = $params{module} or croak "No module";
 695         my $letter_code = $params{letter_code} or croak "No letter_code";
 696         my $branchcode  = $params{branchcode} || '';
 697         my $mtt         = $params{message_transport_type} || 'email';
 698         my $lang        = $params{lang} || 'default';
 699
 700         $letter = getletter( $module, $letter_code, $branchcode, $mtt, $lang );
 701
 702         unless ( $letter ) {
 703             $letter = getletter( $module, $letter_code, $branchcode, $mtt, 'default' )
 704                 or warn( "No $module $letter_code letter transported by " . $mtt ),
 705                     return;
 706         }
 707     }
 708
 709     my $tables = $params{tables} || {};
 710     my $substitute = $params{substitute} || {};
 711     my $loops  = $params{loops} || {}; # loops is not supported for historical notices syntax
 712     my $repeat = $params{repeat};
 713     %$tables || %$substitute || $repeat || %$loops
 714       or carp( "ERROR: nothing to substitute - both 'tables', 'loops' and 'substitute' are empty" ),
 715          return;
 716     my $want_librarian = $params{want_librarian};
 717
 718     if (%$substitute) {
 719         while ( my ($token, $val) = each %$substitute ) {
 720             if ( $token eq 'items.content' ) {
 721                 $val =~ s|\n|<br/>|g if $letter->{is_html};
 722             }
 723
 724             $letter->{title} =~ s/<<$token>>/$val/g;
 725             $letter->{content} =~ s/<<$token>>/$val/g;
 726        }
 727     }
 728
 729     my $OPACBaseURL = C4::Context->preference('OPACBaseURL');
 730     $letter->{content} =~ s/<<OPACBaseURL>>/$OPACBaseURL/go;
 731
 732     if ($want_librarian) {
 733         # parsing librarian name
 734         my $userenv = C4::Context->userenv;
 735         $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/go;
 736         $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/go;
 737         $letter->{content} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/go;
 738     }
 739
 740     my ($repeat_no_enclosing_tags, $repeat_enclosing_tags);
 741
 742     if ($repeat) {
 743         if (ref ($repeat) eq 'ARRAY' ) {
 744             $repeat_no_enclosing_tags = $repeat;
 745         } else {
 746             $repeat_enclosing_tags = $repeat;
 747         }
 748     }
 749
 750     if ($repeat_enclosing_tags) {
 751         while ( my ($tag, $tag_tables) = each %$repeat_enclosing_tags ) {
 752             if ( $letter->{content} =~ m!<$tag>(.*)</$tag>!s ) {
 753                 my $subcontent = $1;
 754                 my @lines = map {
 755                     my %subletter = ( title => '', content => $subcontent );
 756                     _substitute_tables( \%subletter, $_ );
 757                     $subletter{content};
 758                 } @$tag_tables;
 759                 $letter->{content} =~ s!<$tag>.*</$tag>!join( "\n", @lines )!se;
 760             }
 761         }
 762     }
 763
 764     if (%$tables) {
 765         _substitute_tables( $letter, $tables );
 766     }
 767
 768     if ($repeat_no_enclosing_tags) {
 769         if ( $letter->{content} =~ m/[^\n]*<<.*>>[^\n]*/so ) {
 770             my $line = $&;
 771             my $i = 1;
 772             my @lines = map {
 773                 my $c = $line;
 774                 $c =~ s/<<count>>/$i/go;
 775                 foreach my $field ( keys %{$_} ) {
 776                     $c =~ s/(<<[^\.]+.$field>>)/$_->{$field}/;
 777                 }
 778                 $i++;
 779                 $c;
 780             } @$repeat_no_enclosing_tags;
 781
 782             my $replaceby = join( "\n", @lines );
 783             $letter->{content} =~ s/\Q$line\E/$replaceby/s;
 784         }
 785     }
 786
 787     $letter->{content} = _process_tt(
 788         {
 789             content => $letter->{content},
 790             tables  => $tables,
 791             loops  => $loops,
 792             substitute => $substitute,
 793         }
 794     );
 795
 796     $letter->{content} =~ s/<<\S*>>//go; #remove any stragglers
 797
 798     return $letter;
 799 }
 800
 801 sub _substitute_tables {
 802     my ( $letter, $tables ) = @_;
 803     while ( my ($table, $param) = each %$tables ) {
 804         next unless $param;
 805
 806         my $ref = ref $param;
 807
 808         my $values;
 809         if ($ref && $ref eq 'HASH') {
 810             $values = $param;
 811         }
 812         else {
 813             my $sth = _parseletter_sth($table);
 814             unless ($sth) {
 815                 warn "_parseletter_sth('$table') failed to return a valid sth.  No substitution will be done for that table.";
 816                 return;
 817             }
 818             $sth->execute( $ref ? @$param : $param );
 819
 820             $values = $sth->fetchrow_hashref;
 821             $sth->finish();
 822         }
 823
 824         _parseletter ( $letter, $table, $values );
 825     }
 826 }
 827
 828 sub _parseletter_sth {
 829     my $table = shift;
 830     my $sth;
 831     unless ($table) {
 832         carp "ERROR: _parseletter_sth() called without argument (table)";
 833         return;
 834     }
 835     # NOTE: we used to check whether we had a statement handle cached in
 836     #       a %handles module-level variable. This was a dumb move and
 837     #       broke things for the rest of us. prepare_cached is a better
 838     #       way to cache statement handles anyway.
 839     my $query =
 840     ($table eq 'biblio'       )    ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 841     ($table eq 'biblioitems'  )    ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 842     ($table eq 'items'        )    ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 843     ($table eq 'issues'       )    ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 844     ($table eq 'old_issues'   )    ? "SELECT * FROM $table WHERE     itemnumber = ? ORDER BY timestamp DESC LIMIT 1"  :
 845     ($table eq 'reserves'     )    ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?"             :
 846     ($table eq 'borrowers'    )    ? "SELECT * FROM $table WHERE borrowernumber = ?"                                  :
 847     ($table eq 'branches'     )    ? "SELECT * FROM $table WHERE     branchcode = ?"                                  :
 848     ($table eq 'suggestions'  )    ? "SELECT * FROM $table WHERE   suggestionid = ?"                                  :
 849     ($table eq 'aqbooksellers')    ? "SELECT * FROM $table WHERE             id = ?"                                  :
 850     ($table eq 'aqorders'     )    ? "SELECT * FROM $table WHERE    ordernumber = ?"                                  :
 851     ($table eq 'opac_news'    )    ? "SELECT * FROM $table WHERE          idnew = ?"                                  :
 852     ($table eq 'article_requests') ? "SELECT * FROM $table WHERE             id = ?"                                  :
 853     ($table eq 'borrower_modifications') ? "SELECT * FROM $table WHERE verification_token = ?" :
 854     ($table eq 'subscription') ? "SELECT * FROM $table WHERE subscriptionid = ?" :
 855     ($table eq 'serial') ? "SELECT * FROM $table WHERE serialid = ?" :
 856     undef ;
 857     unless ($query) {
 858         warn "ERROR: No _parseletter_sth query for table '$table'";
 859         return;     # nothing to get
 860     }
 861     unless ($sth = C4::Context->dbh->prepare_cached($query)) {
 862         warn "ERROR: Failed to prepare query: '$query'";
 863         return;
 864     }
 865     return $sth;    # now cache is populated for that $table
 866 }
 867
 868 =head2 _parseletter($letter, $table, $values)
 869
 870     parameters :
 871     - $letter : a hash to letter fields (title & content useful)
 872     - $table : the Koha table to parse.
 873     - $values_in : table record hashref
 874     parse all fields from a table, and replace values in title & content with the appropriate value
 875     (not exported sub, used only internally)
 876
 877 =cut
 878
 879 sub _parseletter {
 880     my ( $letter, $table, $values_in ) = @_;
 881
 882     # Work on a local copy of $values_in (passed by reference) to avoid side effects
 883     # in callers ( by changing / formatting values )
 884     my $values = $values_in ? { %$values_in } : {};
 885
 886     if ( $table eq 'borrowers' && $values->{'dateexpiry'} ){
 887         $values->{'dateexpiry'} = output_pref({ str => $values->{dateexpiry}, dateonly => 1 });
 888     }
 889
 890     if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
 891         $values->{'waitingdate'} = output_pref({ dt => dt_from_string( $values->{'waitingdate'} ), dateonly => 1 });
 892     }
 893
 894     if ($letter->{content} && $letter->{content} =~ /<<today>>/) {
 895         my $todaysdate = output_pref( DateTime->now() );
 896         $letter->{content} =~ s/<<today>>/$todaysdate/go;
 897     }
 898
 899     while ( my ($field, $val) = each %$values ) {
 900         $val =~ s/\p{P}$// if $val && $table=~/biblio/;
 901             #BZ 9886: Assuming that we want to eliminate ISBD punctuation here
 902             #Therefore adding the test on biblio. This includes biblioitems,
 903             #but excludes items. Removed unneeded global and lookahead.
 904
 905         if ( $table=~/^borrowers$/ && $field=~/^streettype$/ ) {
 906             my $av = Koha::AuthorisedValues->search({ category => 'ROADTYPE', authorised_value => $val });
 907             $val = $av->count ? $av->next->lib : '';
 908         }
 909
 910         # Dates replacement
 911         my $replacedby   = defined ($val) ? $val : '';
 912         if (    $replacedby
 913             and not $replacedby =~ m|0000-00-00|
 914             and not $replacedby =~ m|9999-12-31|
 915             and $replacedby =~ m|^\d{4}-\d{2}-\d{2}( \d{2}:\d{2}:\d{2})?$| )
 916         {
 917             # If the value is XXXX-YY-ZZ[ AA:BB:CC] we assume it is a date
 918             my $dateonly = defined $1 ? 0 : 1; #$1 refers to the capture group wrapped in parentheses. In this case, that's the hours, minutes, seconds.
 919             my $re_dateonly_filter = qr{ $field( \s* \| \s* dateonly\s*)?>> }xms;
 920
 921             for my $letter_field ( qw( title content ) ) {
 922                 my $filter_string_used = q{};
 923                 if ( $letter->{ $letter_field } =~ $re_dateonly_filter ) {
 924                     # We overwrite $dateonly if the filter exists and we have a time in the datetime
 925                     $filter_string_used = $1 || q{};
 926                     $dateonly = $1 unless $dateonly;
 927                 }
 928                 my $replacedby_date = eval {
 929                     output_pref({ dt => dt_from_string( $replacedby ), dateonly => $dateonly });
 930                 };
 931
 932                 if ( $letter->{ $letter_field } ) {
 933                     $letter->{ $letter_field } =~ s/\Q<<$table.$field$filter_string_used>>\E/$replacedby_date/g;
 934                     $letter->{ $letter_field } =~ s/\Q<<$field$filter_string_used>>\E/$replacedby_date/g;
 935                 }
 936             }
 937         }
 938         # Other fields replacement
 939         else {
 940             for my $letter_field ( qw( title content ) ) {
 941                 if ( $letter->{ $letter_field } ) {
 942                     $letter->{ $letter_field }   =~ s/<<$table.$field>>/$replacedby/g;
 943                     $letter->{ $letter_field }   =~ s/<<$field>>/$replacedby/g;
 944                 }
 945             }
 946         }
 947     }
 948
 949     if ($table eq 'borrowers' && $letter->{content}) {
 950         if ( my $attributes = GetBorrowerAttributes($values->{borrowernumber}) ) {
 951             my %attr;
 952             foreach (@$attributes) {
 953                 my $code = $_->{code};
 954                 my $val  = $_->{value_description} || $_->{value};
 955                 $val =~ s/\p{P}(?=$)//g if $val;
 956                 next unless $val gt '';
 957                 $attr{$code} ||= [];
 958                 push @{ $attr{$code} }, $val;
 959             }
 960             while ( my ($code, $val_ar) = each %attr ) {
 961                 my $replacefield = "<<borrower-attribute:$code>>";
 962                 my $replacedby   = join ',', @$val_ar;
 963                 $letter->{content} =~ s/$replacefield/$replacedby/g;
 964             }
 965         }
 966     }
 967     return $letter;
 968 }
 969
 970 =head2 EnqueueLetter
 971
 972   my $success = EnqueueLetter( { letter => $letter,
 973         borrowernumber => '12', message_transport_type => 'email' } )
 974
 975 places a letter in the message_queue database table, which will
 976 eventually get processed (sent) by the process_message_queue.pl
 977 cronjob when it calls SendQueuedMessages.
 978
 979 return message_id on success
 980
 981 =cut
 982
 983 sub EnqueueLetter {
 984     my $params = shift or return;
 985
 986     return unless exists $params->{'letter'};
 987 #   return unless exists $params->{'borrowernumber'};
 988     return unless exists $params->{'message_transport_type'};
 989
 990     my $content = $params->{letter}->{content};
 991     $content =~ s/\s+//g if(defined $content);
 992     if ( not defined $content or $content eq '' ) {
 993         warn "Trying to add an empty message to the message queue" if $debug;
 994         return;
 995     }
 996
 997     # If we have any attachments we should encode then into the body.
 998     if ( $params->{'attachments'} ) {
 999         $params->{'letter'} = _add_attachments(
1000             {   letter      => $params->{'letter'},
1001                 attachments => $params->{'attachments'},
1002                 message     => MIME::Lite->new( Type => 'multipart/mixed' ),
1003             }
1004         );
1005     }
1006
1007     my $dbh       = C4::Context->dbh();
1008     my $statement = << 'ENDSQL';
1009 INSERT INTO message_queue
1010 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type )
1011 VALUES
1012 ( ?,              ?,       ?,       ?,        ?,           ?,                      ?,      NOW(),       ?,          ?,            ? )
1013 ENDSQL
1014
1015     my $sth    = $dbh->prepare($statement);
1016     my $result = $sth->execute(
1017         $params->{'borrowernumber'},              # borrowernumber
1018         $params->{'letter'}->{'title'},           # subject
1019         $params->{'letter'}->{'content'},         # content
1020         $params->{'letter'}->{'metadata'} || '',  # metadata
1021         $params->{'letter'}->{'code'}     || '',  # letter_code
1022         $params->{'message_transport_type'},      # message_transport_type
1023         'pending',                                # status
1024         $params->{'to_address'},                  # to_address
1025         $params->{'from_address'},                # from_address
1026         $params->{'letter'}->{'content-type'},    # content_type
1027     );
1028     return $dbh->last_insert_id(undef,undef,'message_queue', undef);
1029 }
1030
1031 =head2 SendQueuedMessages ([$hashref])
1032
1033     my $sent = SendQueuedMessages({
1034         letter_code => $letter_code,
1035         borrowernumber => $who_letter_is_for,
1036         limit => 50,
1037         verbose => 1,
1038         type => 'sms',
1039     });
1040
1041 Sends all of the 'pending' items in the message queue, unless
1042 parameters are passed.
1043
1044 The letter_code, borrowernumber and limit parameters are used
1045 to build a parameter set for _get_unsent_messages, thus limiting
1046 which pending messages will be processed. They are all optional.
1047
1048 The verbose parameter can be used to generate debugging output.
1049 It is also optional.
1050
1051 Returns number of messages sent.
1052
1053 =cut
1054
1055 sub SendQueuedMessages {
1056     my $params = shift;
1057
1058     my $which_unsent_messages  = {
1059         'limit'          => $params->{'limit'} // 0,
1060         'borrowernumber' => $params->{'borrowernumber'} // q{},
1061         'letter_code'    => $params->{'letter_code'} // q{},
1062         'type'           => $params->{'type'} // q{},
1063     };
1064     my $unsent_messages = _get_unsent_messages( $which_unsent_messages );
1065     MESSAGE: foreach my $message ( @$unsent_messages ) {
1066         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
1067         warn sprintf( 'sending %s message to patron: %s',
1068                       $message->{'message_transport_type'},
1069                       $message->{'borrowernumber'} || 'Admin' )
1070           if $params->{'verbose'} or $debug;
1071         # This is just begging for subclassing
1072         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
1073         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
1074             _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
1075         }
1076         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
1077             if ( C4::Context->preference('SMSSendDriver') eq 'Email' ) {
1078                 my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1079                 my $sms_provider = Koha::SMS::Providers->find( $patron->sms_provider_id );
1080                 unless ( $sms_provider ) {
1081                     warn sprintf( "Patron %s has no sms provider id set!", $message->{'borrowernumber'} ) if $params->{'verbose'} or $debug;
1082                     _set_message_status( { message_id => $message->{'message_id'}, status => 'failed' } );
1083                     next MESSAGE;
1084                 }
1085                 unless ( $patron->smsalertnumber ) {
1086                     _set_message_status( { message_id => $message->{'message_id'}, status => 'failed' } );
1087                     warn sprintf( "No smsalertnumber found for patron %s!", $message->{'borrowernumber'} ) if $params->{'verbose'} or $debug;
1088                     next MESSAGE;
1089                 }
1090                 $message->{to_address}  = $patron->smsalertnumber; #Sometime this is set to email - sms should always use smsalertnumber
1091                 $message->{to_address} .= '@' . $sms_provider->domain();
1092                 _update_message_to_address($message->{'message_id'},$message->{to_address});
1093                 _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
1094             } else {
1095                 _send_message_by_sms( $message );
1096             }
1097         }
1098     }
1099     return scalar( @$unsent_messages );
1100 }
1101
1102 =head2 GetRSSMessages
1103
1104   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
1105
1106 returns a listref of all queued RSS messages for a particular person.
1107
1108 =cut
1109
1110 sub GetRSSMessages {
1111     my $params = shift;
1112
1113     return unless $params;
1114     return unless ref $params;
1115     return unless $params->{'borrowernumber'};
1116
1117     return _get_unsent_messages( { message_transport_type => 'rss',
1118                                    limit                  => $params->{'limit'},
1119                                    borrowernumber         => $params->{'borrowernumber'}, } );
1120 }
1121
1122 =head2 GetPrintMessages
1123
1124   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
1125
1126 Returns a arrayref of all queued print messages (optionally, for a particular
1127 person).
1128
1129 =cut
1130
1131 sub GetPrintMessages {
1132     my $params = shift || {};
1133
1134     return _get_unsent_messages( { message_transport_type => 'print',
1135                                    borrowernumber         => $params->{'borrowernumber'},
1136                                  } );
1137 }
1138
1139 =head2 GetQueuedMessages ([$hashref])
1140
1141   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
1142
1143 fetches messages out of the message queue.
1144
1145 returns:
1146 list of hashes, each has represents a message in the message queue.
1147
1148 =cut
1149
1150 sub GetQueuedMessages {
1151     my $params = shift;
1152
1153     my $dbh = C4::Context->dbh();
1154     my $statement = << 'ENDSQL';
1155 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued
1156 FROM message_queue
1157 ENDSQL
1158
1159     my @query_params;
1160     my @whereclauses;
1161     if ( exists $params->{'borrowernumber'} ) {
1162         push @whereclauses, ' borrowernumber = ? ';
1163         push @query_params, $params->{'borrowernumber'};
1164     }
1165
1166     if ( @whereclauses ) {
1167         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
1168     }
1169
1170     if ( defined $params->{'limit'} ) {
1171         $statement .= ' LIMIT ? ';
1172         push @query_params, $params->{'limit'};
1173     }
1174
1175     my $sth = $dbh->prepare( $statement );
1176     my $result = $sth->execute( @query_params );
1177     return $sth->fetchall_arrayref({});
1178 }
1179
1180 =head2 GetMessageTransportTypes
1181
1182   my @mtt = GetMessageTransportTypes();
1183
1184   returns an arrayref of transport types
1185
1186 =cut
1187
1188 sub GetMessageTransportTypes {
1189     my $dbh = C4::Context->dbh();
1190     my $mtts = $dbh->selectcol_arrayref("
1191         SELECT message_transport_type
1192         FROM message_transport_types
1193         ORDER BY message_transport_type
1194     ");
1195     return $mtts;
1196 }
1197
1198 =head2 GetMessage
1199
1200     my $message = C4::Letters::Message($message_id);
1201
1202 =cut
1203
1204 sub GetMessage {
1205     my ( $message_id ) = @_;
1206     return unless $message_id;
1207     my $dbh = C4::Context->dbh;
1208     return $dbh->selectrow_hashref(q|
1209         SELECT message_id, borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type
1210         FROM message_queue
1211         WHERE message_id = ?
1212     |, {}, $message_id );
1213 }
1214
1215 =head2 ResendMessage
1216
1217   Attempt to resend a message which has failed previously.
1218
1219   my $has_been_resent = C4::Letters::ResendMessage($message_id);
1220
1221   Updates the message to 'pending' status so that
1222   it will be resent later on.
1223
1224   returns 1 on success, 0 on failure, undef if no message was found
1225
1226 =cut
1227
1228 sub ResendMessage {
1229     my $message_id = shift;
1230     return unless $message_id;
1231
1232     my $message = GetMessage( $message_id );
1233     return unless $message;
1234     my $rv = 0;
1235     if ( $message->{status} ne 'pending' ) {
1236         $rv = C4::Letters::_set_message_status({
1237             message_id => $message_id,
1238             status => 'pending',
1239         });
1240         $rv = $rv > 0? 1: 0;
1241         # Clear destination email address to force address update
1242         _update_message_to_address( $message_id, undef ) if $rv &&
1243             $message->{message_transport_type} eq 'email';
1244     }
1245     return $rv;
1246 }
1247
1248 =head2 _add_attachements
1249
1250   named parameters:
1251   letter - the standard letter hashref
1252   attachments - listref of attachments. each attachment is a hashref of:
1253     type - the mime type, like 'text/plain'
1254     content - the actual attachment
1255     filename - the name of the attachment.
1256   message - a MIME::Lite object to attach these to.
1257
1258   returns your letter object, with the content updated.
1259
1260 =cut
1261
1262 sub _add_attachments {
1263     my $params = shift;
1264
1265     my $letter = $params->{'letter'};
1266     my $attachments = $params->{'attachments'};
1267     return $letter unless @$attachments;
1268     my $message = $params->{'message'};
1269
1270     # First, we have to put the body in as the first attachment
1271     $message->attach(
1272         Type => $letter->{'content-type'} || 'TEXT',
1273         Data => $letter->{'is_html'}
1274             ? _wrap_html($letter->{'content'}, $letter->{'title'})
1275             : $letter->{'content'},
1276     );
1277
1278     foreach my $attachment ( @$attachments ) {
1279         $message->attach(
1280             Type     => $attachment->{'type'},
1281             Data     => $attachment->{'content'},
1282             Filename => $attachment->{'filename'},
1283         );
1284     }
1285     # we're forcing list context here to get the header, not the count back from grep.
1286     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
1287     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
1288     $letter->{'content'} = $message->body_as_string;
1289
1290     return $letter;
1291
1292 }
1293
1294 =head2 _get_unsent_messages
1295
1296   This function's parameter hash reference takes the following
1297   optional named parameters:
1298    message_transport_type: method of message sending (e.g. email, sms, etc.)
1299    borrowernumber        : who the message is to be sent
1300    letter_code           : type of message being sent (e.g. PASSWORD_RESET)
1301    limit                 : maximum number of messages to send
1302
1303   This function returns an array of matching hash referenced rows from
1304   message_queue with some borrower information added.
1305
1306 =cut
1307
1308 sub _get_unsent_messages {
1309     my $params = shift;
1310
1311     my $dbh = C4::Context->dbh();
1312     my $statement = qq{
1313         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
1314         FROM message_queue mq
1315         LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
1316         WHERE status = ?
1317     };
1318
1319     my @query_params = ('pending');
1320     if ( ref $params ) {
1321         if ( $params->{'message_transport_type'} ) {
1322             $statement .= ' AND mq.message_transport_type = ? ';
1323             push @query_params, $params->{'message_transport_type'};
1324         }
1325         if ( $params->{'borrowernumber'} ) {
1326             $statement .= ' AND mq.borrowernumber = ? ';
1327             push @query_params, $params->{'borrowernumber'};
1328         }
1329         if ( $params->{'letter_code'} ) {
1330             $statement .= ' AND mq.letter_code = ? ';
1331             push @query_params, $params->{'letter_code'};
1332         }
1333         if ( $params->{'type'} ) {
1334             $statement .= ' AND message_transport_type = ? ';
1335             push @query_params, $params->{'type'};
1336         }
1337         if ( $params->{'limit'} ) {
1338             $statement .= ' limit ? ';
1339             push @query_params, $params->{'limit'};
1340         }
1341     }
1342
1343     $debug and warn "_get_unsent_messages SQL: $statement";
1344     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
1345     my $sth = $dbh->prepare( $statement );
1346     my $result = $sth->execute( @query_params );
1347     return $sth->fetchall_arrayref({});
1348 }
1349
1350 sub _send_message_by_email {
1351     my $message = shift or return;
1352     my ($username, $password, $method) = @_;
1353
1354     my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1355     my $to_address = $message->{'to_address'};
1356     unless ($to_address) {
1357         unless ($patron) {
1358             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
1359             _set_message_status( { message_id => $message->{'message_id'},
1360                                    status     => 'failed' } );
1361             return;
1362         }
1363         $to_address = $patron->notice_email_address;
1364         unless ($to_address) {
1365             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
1366             # warning too verbose for this more common case?
1367             _set_message_status( { message_id => $message->{'message_id'},
1368                                    status     => 'failed' } );
1369             return;
1370         }
1371     }
1372
1373     my $utf8   = decode('MIME-Header', $message->{'subject'} );
1374     $message->{subject}= encode('MIME-Header', $utf8);
1375     my $subject = encode('UTF-8', $message->{'subject'});
1376     my $content = encode('UTF-8', $message->{'content'});
1377     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
1378     my $is_html = $content_type =~ m/html/io;
1379     my $branch_email = undef;
1380     my $branch_replyto = undef;
1381     my $branch_returnpath = undef;
1382     if ($patron) {
1383         my $library = $patron->library;
1384         $branch_email      = $library->branchemail;
1385         $branch_replyto    = $library->branchreplyto;
1386         $branch_returnpath = $library->branchreturnpath;
1387     }
1388     my $email = Koha::Email->new();
1389     my %sendmail_params = $email->create_message_headers(
1390         {
1391             to      => $to_address,
1392             from    => $message->{'from_address'} || $branch_email,
1393             replyto => $branch_replyto,
1394             sender  => $branch_returnpath,
1395             subject => $subject,
1396             message => $is_html ? _wrap_html( $content, $subject ) : $content,
1397             contenttype => $content_type
1398         }
1399     );
1400
1401     $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
1402     if ( my $bcc = C4::Context->preference('NoticeBcc') ) {
1403        $sendmail_params{ Bcc } = $bcc;
1404     }
1405
1406     _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
1407
1408     if ( Mail::Sendmail::sendmail( %sendmail_params ) ) {
1409         _set_message_status( { message_id => $message->{'message_id'},
1410                 status     => 'sent' } );
1411         return 1;
1412     } else {
1413         _set_message_status( { message_id => $message->{'message_id'},
1414                 status     => 'failed' } );
1415         carp $Mail::Sendmail::error;
1416         return;
1417     }
1418 }
1419
1420 sub _wrap_html {
1421     my ($content, $title) = @_;
1422
1423     my $css = C4::Context->preference("NoticeCSS") || '';
1424     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
1425     return <<EOS;
1426 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1427     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1428 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1429 <head>
1430 <title>$title</title>
1431 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1432 $css
1433 </head>
1434 <body>
1435 $content
1436 </body>
1437 </html>
1438 EOS
1439 }
1440
1441 sub _is_duplicate {
1442     my ( $message ) = @_;
1443     my $dbh = C4::Context->dbh;
1444     my $count = $dbh->selectrow_array(q|
1445         SELECT COUNT(*)
1446         FROM message_queue
1447         WHERE message_transport_type = ?
1448         AND borrowernumber = ?
1449         AND letter_code = ?
1450         AND CAST(time_queued AS date) = CAST(NOW() AS date)
1451         AND status="sent"
1452         AND content = ?
1453     |, {}, $message->{message_transport_type}, $message->{borrowernumber}, $message->{letter_code}, $message->{content} );
1454     return $count;
1455 }
1456
1457 sub _send_message_by_sms {
1458     my $message = shift or return;
1459     my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1460
1461     unless ( $patron and $patron->smsalertnumber ) {
1462         _set_message_status( { message_id => $message->{'message_id'},
1463                                status     => 'failed' } );
1464         return;
1465     }
1466
1467     if ( _is_duplicate( $message ) ) {
1468         _set_message_status( { message_id => $message->{'message_id'},
1469                                status     => 'failed' } );
1470         return;
1471     }
1472
1473     my $success = C4::SMS->send_sms( { destination => $patron->smsalertnumber,
1474                                        message     => $message->{'content'},
1475                                      } );
1476     _set_message_status( { message_id => $message->{'message_id'},
1477                            status     => ($success ? 'sent' : 'failed') } );
1478     return $success;
1479 }
1480
1481 sub _update_message_to_address {
1482     my ($id, $to)= @_;
1483     my $dbh = C4::Context->dbh();
1484     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1485 }
1486
1487 sub _set_message_status {
1488     my $params = shift or return;
1489
1490     foreach my $required_parameter ( qw( message_id status ) ) {
1491         return unless exists $params->{ $required_parameter };
1492     }
1493
1494     my $dbh = C4::Context->dbh();
1495     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1496     my $sth = $dbh->prepare( $statement );
1497     my $result = $sth->execute( $params->{'status'},
1498                                 $params->{'message_id'} );
1499     return $result;
1500 }
1501
1502 sub _process_tt {
1503     my ( $params ) = @_;
1504
1505     my $content = $params->{content};
1506     my $tables = $params->{tables};
1507     my $loops = $params->{loops};
1508     my $substitute = $params->{substitute} || {};
1509
1510     my $use_template_cache = C4::Context->config('template_cache_dir') && defined $ENV{GATEWAY_INTERFACE};
1511     my $template           = Template->new(
1512         {
1513             EVAL_PERL    => 1,
1514             ABSOLUTE     => 1,
1515             PLUGIN_BASE  => 'Koha::Template::Plugin',
1516             COMPILE_EXT  => $use_template_cache ? '.ttc' : '',
1517             COMPILE_DIR  => $use_template_cache ? C4::Context->config('template_cache_dir') : '',
1518             FILTERS      => {},
1519             ENCODING     => 'UTF-8',
1520         }
1521     ) or die Template->error();
1522
1523     my $tt_params = { %{ _get_tt_params( $tables ) }, %{ _get_tt_params( $loops, 'is_a_loop' ) }, %$substitute };
1524
1525     $content = add_tt_filters( $content );
1526     $content = qq|[% USE KohaDates %][% USE Remove_MARC_punctuation %]$content|;
1527
1528     my $output;
1529     $template->process( \$content, $tt_params, \$output ) || croak "ERROR PROCESSING TEMPLATE: " . $template->error();
1530
1531     return $output;
1532 }
1533
1534 sub _get_tt_params {
1535     my ($tables, $is_a_loop) = @_;
1536
1537     my $params;
1538     $is_a_loop ||= 0;
1539
1540     my $config = {
1541         article_requests => {
1542             module   => 'Koha::ArticleRequests',
1543             singular => 'article_request',
1544             plural   => 'article_requests',
1545             pk       => 'id',
1546           },
1547         biblio => {
1548             module   => 'Koha::Biblios',
1549             singular => 'biblio',
1550             plural   => 'biblios',
1551             pk       => 'biblionumber',
1552         },
1553         biblioitems => {
1554             module   => 'Koha::Biblioitems',
1555             singular => 'biblioitem',
1556             plural   => 'biblioitems',
1557             pk       => 'biblioitemnumber',
1558         },
1559         borrowers => {
1560             module   => 'Koha::Patrons',
1561             singular => 'borrower',
1562             plural   => 'borrowers',
1563             pk       => 'borrowernumber',
1564         },
1565         branches => {
1566             module   => 'Koha::Libraries',
1567             singular => 'branch',
1568             plural   => 'branches',
1569             pk       => 'branchcode',
1570         },
1571         items => {
1572             module   => 'Koha::Items',
1573             singular => 'item',
1574             plural   => 'items',
1575             pk       => 'itemnumber',
1576         },
1577         opac_news => {
1578             module   => 'Koha::News',
1579             singular => 'news',
1580             plural   => 'news',
1581             pk       => 'idnew',
1582         },
1583         aqorders => {
1584             module   => 'Koha::Acquisition::Orders',
1585             singular => 'order',
1586             plural   => 'orders',
1587             pk       => 'ordernumber',
1588         },
1589         reserves => {
1590             module   => 'Koha::Holds',
1591             singular => 'hold',
1592             plural   => 'holds',
1593             fk       => [ 'borrowernumber', 'biblionumber' ],
1594         },
1595         serial => {
1596             module   => 'Koha::Serials',
1597             singular => 'serial',
1598             plural   => 'serials',
1599             pk       => 'serialid',
1600         },
1601         subscription => {
1602             module   => 'Koha::Subscriptions',
1603             singular => 'subscription',
1604             plural   => 'subscriptions',
1605             pk       => 'subscriptionid',
1606         },
1607         suggestions => {
1608             module   => 'Koha::Suggestions',
1609             singular => 'suggestion',
1610             plural   => 'suggestions',
1611             pk       => 'suggestionid',
1612         },
1613         issues => {
1614             module   => 'Koha::Checkouts',
1615             singular => 'checkout',
1616             plural   => 'checkouts',
1617             fk       => 'itemnumber',
1618         },
1619         old_issues => {
1620             module   => 'Koha::Old::Checkouts',
1621             singular => 'old_checkout',
1622             plural   => 'old_checkouts',
1623             fk       => 'itemnumber',
1624         },
1625         overdues => {
1626             module   => 'Koha::Checkouts',
1627             singular => 'overdue',
1628             plural   => 'overdues',
1629             fk       => 'itemnumber',
1630         },
1631         borrower_modifications => {
1632             module   => 'Koha::Patron::Modifications',
1633             singular => 'patron_modification',
1634             plural   => 'patron_modifications',
1635             fk       => 'verification_token',
1636         },
1637     };
1638
1639     foreach my $table ( keys %$tables ) {
1640         next unless $config->{$table};
1641
1642         my $ref = ref( $tables->{$table} ) || q{};
1643         my $module = $config->{$table}->{module};
1644
1645         if ( can_load( modules => { $module => undef } ) ) {
1646             my $pk = $config->{$table}->{pk};
1647             my $fk = $config->{$table}->{fk};
1648
1649             if ( $is_a_loop ) {
1650                 my $values = $tables->{$table} || [];
1651                 unless ( ref( $values ) eq 'ARRAY' ) {
1652                     croak "ERROR processing table $table. Wrong API call.";
1653                 }
1654                 my $key = $pk ? $pk : $fk;
1655                 # $key does not come from user input
1656                 my $objects = $module->search(
1657                     { $key => $values },
1658                     {
1659                             # We want to retrieve the data in the same order
1660                             # FIXME MySQLism
1661                             # field is a MySQLism, but they are no other way to do it
1662                             # To be generic we could do it in perl, but we will need to fetch
1663                             # all the data then order them
1664                         @$values ? ( order_by => \[ "field($key, " . join( ', ', @$values ) . ")" ] ) : ()
1665                     }
1666                 );
1667                 $params->{ $config->{$table}->{plural} } = $objects;
1668             }
1669             elsif ( $ref eq q{} || $ref eq 'HASH' ) {
1670                 my $id = ref $ref eq 'HASH' ? $tables->{$table}->{$pk} : $tables->{$table};
1671                 my $object;
1672                 if ( $fk ) { # Using a foreign key for lookup
1673                     if ( ref( $fk ) eq 'ARRAY' ) { # Foreign key is multi-column
1674                         my $search;
1675                         foreach my $key ( @$fk ) {
1676                             $search->{$key} = $id->{$key};
1677                         }
1678                         $object = $module->search( $search )->last();
1679                     } else { # Foreign key is single column
1680                         $object = $module->search( { $fk => $id } )->last();
1681                     }
1682                 } else { # using the table's primary key for lookup
1683                     $object = $module->find($id);
1684                 }
1685                 $params->{ $config->{$table}->{singular} } = $object;
1686             }
1687             else {    # $ref eq 'ARRAY'
1688                 my $object;
1689                 if ( @{ $tables->{$table} } == 1 ) {    # Param is a single key
1690                     $object = $module->search( { $pk => $tables->{$table} } )->last();
1691                 }
1692                 else {                                  # Params are mutliple foreign keys
1693                     croak "Multiple foreign keys (table $table) should be passed using an hashref";
1694                 }
1695                 $params->{ $config->{$table}->{singular} } = $object;
1696             }
1697         }
1698         else {
1699             croak "ERROR LOADING MODULE $module: $Module::Load::Conditional::ERROR";
1700         }
1701     }
1702
1703     $params->{today} = output_pref({ dt => dt_from_string, dateformat => 'iso' });
1704
1705     return $params;
1706 }
1707
1708 =head3 add_tt_filters
1709
1710 $content = add_tt_filters( $content );
1711
1712 Add TT filters to some specific fields if needed.
1713
1714 For now we only add the Remove_MARC_punctuation TT filter to biblio and biblioitem fields
1715
1716 =cut
1717
1718 sub add_tt_filters {
1719     my ( $content ) = @_;
1720     $content =~ s|\[%\s*biblio\.(.*?)\s*%\]|[% biblio.$1 \| \$Remove_MARC_punctuation %]|gxms;
1721     $content =~ s|\[%\s*biblioitem\.(.*?)\s*%\]|[% biblioitem.$1 \| \$Remove_MARC_punctuation %]|gxms;
1722     return $content;
1723 }
1724
1725 =head2 get_item_content
1726
1727     my $item = Koha::Items->find(...)->unblessed;
1728     my @item_content_fields = qw( date_due title barcode author itemnumber );
1729     my $item_content = C4::Letters::get_item_content({
1730                              item => $item,
1731                              item_content_fields => \@item_content_fields
1732                        });
1733
1734 This function generates a tab-separated list of values for the passed item. Dates
1735 are formatted following the current setup.
1736
1737 =cut
1738
1739 sub get_item_content {
1740     my ( $params ) = @_;
1741     my $item = $params->{item};
1742     my $dateonly = $params->{dateonly} || 0;
1743     my $item_content_fields = $params->{item_content_fields} || [];
1744
1745     return unless $item;
1746
1747     my @item_info = map {
1748         $_ =~ /^date|date$/
1749           ? eval {
1750             output_pref(
1751                 { dt => dt_from_string( $item->{$_} ), dateonly => $dateonly } );
1752           }
1753           : $item->{$_}
1754           || ''
1755     } @$item_content_fields;
1756     return join( "\t", @item_info ) . "\n";
1757 }
1758
1759 1;
1760 __END__