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