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 =cut
  75
  76 sub GetLetters {
  77     my ($filters) = @_;
  78     my $module    = $filters->{module};
  79     my $code      = $filters->{code};
  80     my $branchcode = $filters->{branchcode};
  81     my $dbh       = C4::Context->dbh;
  82     my $letters   = $dbh->selectall_arrayref(
  83         q|
  84             SELECT module, code, branchcode, name
  85             FROM letter
  86             WHERE 1
  87         |
  88           . ( $module ? q| AND module = ?| : q|| )
  89           . ( $code   ? q| AND code = ?|   : q|| )
  90           . ( defined $branchcode   ? q| AND branchcode = ?|   : q|| )
  91           . q| GROUP BY code ORDER BY name|, { Slice => {} }
  92         , ( $module ? $module : () )
  93         , ( $code ? $code : () )
  94         , ( defined $branchcode ? $branchcode : () )
  95     );
  96
  97     return $letters;
  98 }
  99
 100 =head2 GetLetterTemplates
 101
 102     my $letter_templates = GetLetterTemplates(
 103         {
 104             module => 'circulation',
 105             code => 'my code',
 106             branchcode => 'CPL', # '' for default,
 107         }
 108     );
 109
 110     Return a hashref of letter templates.
 111
 112 =cut
 113
 114 sub GetLetterTemplates {
 115     my ( $params ) = @_;
 116
 117     my $module    = $params->{module};
 118     my $code      = $params->{code};
 119     my $branchcode = $params->{branchcode} // '';
 120     my $dbh       = C4::Context->dbh;
 121     my $letters   = $dbh->selectall_arrayref(
 122         q|
 123             SELECT module, code, branchcode, name, is_html, title, content, message_transport_type, lang
 124             FROM letter
 125             WHERE module = ?
 126             AND code = ?
 127             and branchcode = ?
 128         |
 129         , { Slice => {} }
 130         , $module, $code, $branchcode
 131     );
 132
 133     return $letters;
 134 }
 135
 136 =head2 GetLettersAvailableForALibrary
 137
 138     my $letters = GetLettersAvailableForALibrary(
 139         {
 140             branchcode => 'CPL', # '' for default
 141             module => 'circulation',
 142         }
 143     );
 144
 145     Return an arrayref of letters, sorted by name.
 146     If a specific letter exist for the given branchcode, it will be retrieve.
 147     Otherwise the default letter will be.
 148
 149 =cut
 150
 151 sub GetLettersAvailableForALibrary {
 152     my ($filters)  = @_;
 153     my $branchcode = $filters->{branchcode};
 154     my $module     = $filters->{module};
 155
 156     croak "module should be provided" unless $module;
 157
 158     my $dbh             = C4::Context->dbh;
 159     my $default_letters = $dbh->selectall_arrayref(
 160         q|
 161             SELECT module, code, branchcode, name
 162             FROM letter
 163             WHERE 1
 164         |
 165           . q| AND branchcode = ''|
 166           . ( $module ? q| AND module = ?| : q|| )
 167           . q| ORDER BY name|, { Slice => {} }
 168         , ( $module ? $module : () )
 169     );
 170
 171     my $specific_letters;
 172     if ($branchcode) {
 173         $specific_letters = $dbh->selectall_arrayref(
 174             q|
 175                 SELECT module, code, branchcode, name
 176                 FROM letter
 177                 WHERE 1
 178             |
 179               . q| AND branchcode = ?|
 180               . ( $module ? q| AND module = ?| : q|| )
 181               . q| ORDER BY name|, { Slice => {} }
 182             , $branchcode
 183             , ( $module ? $module : () )
 184         );
 185     }
 186
 187     my %letters;
 188     for my $l (@$default_letters) {
 189         $letters{ $l->{code} } = $l;
 190     }
 191     for my $l (@$specific_letters) {
 192         # Overwrite the default letter with the specific one.
 193         $letters{ $l->{code} } = $l;
 194     }
 195
 196     return [ map { $letters{$_} }
 197           sort { $letters{$a}->{name} cmp $letters{$b}->{name} }
 198           keys %letters ];
 199
 200 }
 201
 202 sub getletter {
 203     my ( $module, $code, $branchcode, $message_transport_type, $lang) = @_;
 204     $message_transport_type //= '%';
 205     $lang = 'default' unless( $lang && C4::Context->preference('TranslateNotices') );
 206
 207
 208     my $only_my_library = C4::Context->only_my_library;
 209     if ( $only_my_library and $branchcode ) {
 210         $branchcode = C4::Context::mybranch();
 211     }
 212     $branchcode //= '';
 213
 214     my $dbh = C4::Context->dbh;
 215     my $sth = $dbh->prepare(q{
 216         SELECT *
 217         FROM letter
 218         WHERE module=? AND code=? AND (branchcode = ? OR branchcode = '')
 219         AND message_transport_type LIKE ?
 220         AND lang =?
 221         ORDER BY branchcode DESC LIMIT 1
 222     });
 223     $sth->execute( $module, $code, $branchcode, $message_transport_type, $lang );
 224     my $line = $sth->fetchrow_hashref
 225       or return;
 226     $line->{'content-type'} = 'text/html; charset="UTF-8"' if $line->{is_html};
 227     return { %$line };
 228 }
 229
 230
 231 =head2 DelLetter
 232
 233     DelLetter(
 234         {
 235             branchcode => 'CPL',
 236             module => 'circulation',
 237             code => 'my code',
 238             [ mtt => 'email', ]
 239         }
 240     );
 241
 242     Delete the letter. The mtt parameter is facultative.
 243     If not given, all templates mathing the other parameters will be removed.
 244
 245 =cut
 246
 247 sub DelLetter {
 248     my ($params)   = @_;
 249     my $branchcode = $params->{branchcode};
 250     my $module     = $params->{module};
 251     my $code       = $params->{code};
 252     my $mtt        = $params->{mtt};
 253     my $lang       = $params->{lang};
 254     my $dbh        = C4::Context->dbh;
 255     $dbh->do(q|
 256         DELETE FROM letter
 257         WHERE branchcode = ?
 258           AND module = ?
 259           AND code = ?
 260     |
 261     . ( $mtt ? q| AND message_transport_type = ?| : q|| )
 262     . ( $lang? q| AND lang = ?| : q|| )
 263     , undef, $branchcode, $module, $code, ( $mtt ? $mtt : () ), ( $lang ? $lang : () ) );
 264 }
 265
 266 =head2 addalert ($borrowernumber, $type, $externalid)
 267
 268     parameters :
 269     - $borrowernumber : the number of the borrower subscribing to the alert
 270     - $type : the type of alert.
 271     - $externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid.
 272
 273     create an alert and return the alertid (primary key)
 274
 275 =cut
 276
 277 sub addalert {
 278     my ( $borrowernumber, $type, $externalid ) = @_;
 279     my $dbh = C4::Context->dbh;
 280     my $sth =
 281       $dbh->prepare(
 282         "insert into alert (borrowernumber, type, externalid) values (?,?,?)");
 283     $sth->execute( $borrowernumber, $type, $externalid );
 284
 285     # get the alert number newly created and return it
 286     my $alertid = $dbh->{'mysql_insertid'};
 287     return $alertid;
 288 }
 289
 290 =head2 delalert ($alertid)
 291
 292     parameters :
 293     - alertid : the alert id
 294     deletes the alert
 295
 296 =cut
 297
 298 sub delalert {
 299     my $alertid = shift or die "delalert() called without valid argument (alertid)";    # it's gonna die anyway.
 300     $debug and warn "delalert: deleting alertid $alertid";
 301     my $sth = C4::Context->dbh->prepare("delete from alert where alertid=?");
 302     $sth->execute($alertid);
 303 }
 304
 305 =head2 getalert ([$borrowernumber], [$type], [$externalid])
 306
 307     parameters :
 308     - $borrowernumber : the number of the borrower subscribing to the alert
 309     - $type : the type of alert.
 310     - $externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid.
 311     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.
 312
 313 =cut
 314
 315 sub getalert {
 316     my ( $borrowernumber, $type, $externalid ) = @_;
 317     my $dbh   = C4::Context->dbh;
 318     my $query = "SELECT a.*, b.branchcode FROM alert a JOIN borrowers b USING(borrowernumber) WHERE 1";
 319     my @bind;
 320     if ($borrowernumber and $borrowernumber =~ /^\d+$/) {
 321         $query .= " AND borrowernumber=?";
 322         push @bind, $borrowernumber;
 323     }
 324     if ($type) {
 325         $query .= " AND type=?";
 326         push @bind, $type;
 327     }
 328     if ($externalid) {
 329         $query .= " AND externalid=?";
 330         push @bind, $externalid;
 331     }
 332     my $sth = $dbh->prepare($query);
 333     $sth->execute(@bind);
 334     return $sth->fetchall_arrayref({});
 335 }
 336
 337 =head2 findrelatedto($type, $externalid)
 338
 339     parameters :
 340     - $type : the type of alert
 341     - $externalid : the id of the "object" to query
 342
 343     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.
 344     When type=issue, the id is related to a subscriptionid and this sub returns the name of the biblio.
 345
 346 =cut
 347
 348 # outmoded POD:
 349 # When type=virtual, the id is related to a virtual shelf and this sub returns the name of the sub
 350
 351 sub findrelatedto {
 352     my $type       = shift or return;
 353     my $externalid = shift or return;
 354     my $q = ($type eq 'issue'   ) ?
 355 "select title as result from subscription left join biblio on subscription.biblionumber=biblio.biblionumber where subscriptionid=?" :
 356             ($type eq 'borrower') ?
 357 "select concat(firstname,' ',surname) from borrowers where borrowernumber=?" : undef;
 358     unless ($q) {
 359         warn "findrelatedto(): Illegal type '$type'";
 360         return;
 361     }
 362     my $sth = C4::Context->dbh->prepare($q);
 363     $sth->execute($externalid);
 364     my ($result) = $sth->fetchrow;
 365     return $result;
 366 }
 367
 368 =head2 SendAlerts
 369
 370     my $err = &SendAlerts($type, $externalid, $letter_code);
 371
 372     Parameters:
 373       - $type : the type of alert
 374       - $externalid : the id of the "object" to query
 375       - $letter_code : the notice template to use
 376
 377     C<&SendAlerts> sends an email notice directly to a patron or a vendor.
 378
 379     Currently it supports ($type):
 380       - claim serial issues (claimissues)
 381       - claim acquisition orders (claimacquisition)
 382       - send acquisition orders to the vendor (orderacquisition)
 383       - notify patrons about newly received serial issues (issue)
 384       - notify patrons when their account is created (members)
 385
 386     Returns undef or { error => 'message } on failure.
 387     Returns true on success.
 388
 389 =cut
 390
 391 sub SendAlerts {
 392     my ( $type, $externalid, $letter_code ) = @_;
 393     my $dbh = C4::Context->dbh;
 394     if ( $type eq 'issue' ) {
 395
 396         # prepare the letter...
 397         # search the subscriptionid
 398         my $sth =
 399           $dbh->prepare(
 400             "SELECT subscriptionid FROM serial WHERE serialid=?");
 401         $sth->execute($externalid);
 402         my ($subscriptionid) = $sth->fetchrow
 403           or warn( "No subscription for '$externalid'" ),
 404              return;
 405
 406         # search the biblionumber
 407         $sth =
 408           $dbh->prepare(
 409             "SELECT biblionumber FROM subscription WHERE subscriptionid=?");
 410         $sth->execute($subscriptionid);
 411         my ($biblionumber) = $sth->fetchrow
 412           or warn( "No biblionumber for '$subscriptionid'" ),
 413              return;
 414
 415         my %letter;
 416         # find the list of borrowers to alert
 417         my $alerts = getalert( '', 'issue', $subscriptionid );
 418         foreach (@$alerts) {
 419             my $patron = Koha::Patrons->find( $_->{borrowernumber} );
 420             next unless $patron; # Just in case
 421             my $email = $patron->email or next;
 422
 423 #                    warn "sending issues...";
 424             my $userenv = C4::Context->userenv;
 425             my $library = Koha::Libraries->find( $_->{branchcode} );
 426             my $letter = GetPreparedLetter (
 427                 module => 'serial',
 428                 letter_code => $letter_code,
 429                 branchcode => $userenv->{branch},
 430                 tables => {
 431                     'branches'    => $_->{branchcode},
 432                     'biblio'      => $biblionumber,
 433                     'biblioitems' => $biblionumber,
 434                     'borrowers'   => $patron->unblessed,
 435                     'subscription' => $subscriptionid,
 436                     'serial' => $externalid,
 437                 },
 438                 want_librarian => 1,
 439             ) or return;
 440
 441             # ... then send mail
 442             my $message = Koha::Email->new();
 443             my %mail = $message->create_message_headers(
 444                 {
 445                     to      => $email,
 446                     from    => $library->branchemail,
 447                     replyto => $library->branchreplyto,
 448                     sender  => $library->branchreturnpath,
 449                     subject => Encode::encode( "UTF-8", "" . $letter->{title} ),
 450                     message => $letter->{'is_html'}
 451                                 ? _wrap_html( Encode::encode( "UTF-8", $letter->{'content'} ),
 452                                               Encode::encode( "UTF-8", "" . $letter->{'title'} ))
 453                                 : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
 454                     contenttype => $letter->{'is_html'}
 455                                     ? 'text/html; charset="utf-8"'
 456                                     : 'text/plain; charset="utf-8"',
 457                 }
 458             );
 459             unless( Mail::Sendmail::sendmail(%mail) ) {
 460                 carp $Mail::Sendmail::error;
 461                 return { error => $Mail::Sendmail::error };
 462             }
 463         }
 464     }
 465     elsif ( $type eq 'claimacquisition' or $type eq 'claimissues' or $type eq 'orderacquisition' ) {
 466
 467         # prepare the letter...
 468         my $strsth;
 469         my $sthorders;
 470         my $dataorders;
 471         my $action;
 472         if ( $type eq 'claimacquisition') {
 473             $strsth = qq{
 474             SELECT aqorders.*,aqbasket.*,biblio.*,biblioitems.*
 475             FROM aqorders
 476             LEFT JOIN aqbasket ON aqbasket.basketno=aqorders.basketno
 477             LEFT JOIN biblio ON aqorders.biblionumber=biblio.biblionumber
 478             LEFT JOIN biblioitems ON aqorders.biblionumber=biblioitems.biblionumber
 479             WHERE aqorders.ordernumber IN (
 480             };
 481
 482             if (!@$externalid){
 483                 carp "No order selected";
 484                 return { error => "no_order_selected" };
 485             }
 486             $strsth .= join( ",", ('?') x @$externalid ) . ")";
 487             $action = "ACQUISITION CLAIM";
 488             $sthorders = $dbh->prepare($strsth);
 489             $sthorders->execute( @$externalid );
 490             $dataorders = $sthorders->fetchall_arrayref( {} );
 491         }
 492
 493         if ($type eq 'claimissues') {
 494             $strsth = qq{
 495             SELECT serial.*,subscription.*, biblio.*, biblioitems.*, aqbooksellers.*,
 496             aqbooksellers.id AS booksellerid
 497             FROM serial
 498             LEFT JOIN subscription ON serial.subscriptionid=subscription.subscriptionid
 499             LEFT JOIN biblio ON serial.biblionumber=biblio.biblionumber
 500             LEFT JOIN biblioitems ON serial.biblionumber = biblioitems.biblionumber
 501             LEFT JOIN aqbooksellers ON subscription.aqbooksellerid=aqbooksellers.id
 502             WHERE serial.serialid IN (
 503             };
 504
 505             if (!@$externalid){
 506                 carp "No issues selected";
 507                 return { error => "no_issues_selected" };
 508             }
 509
 510             $strsth .= join( ",", ('?') x @$externalid ) . ")";
 511             $action = "SERIAL CLAIM";
 512             $sthorders = $dbh->prepare($strsth);
 513             $sthorders->execute( @$externalid );
 514             $dataorders = $sthorders->fetchall_arrayref( {} );
 515         }
 516
 517         if ( $type eq 'orderacquisition') {
 518             $strsth = qq{
 519             SELECT aqorders.*,aqbasket.*,biblio.*,biblioitems.*
 520             FROM aqorders
 521             LEFT JOIN aqbasket ON aqbasket.basketno=aqorders.basketno
 522             LEFT JOIN biblio ON aqorders.biblionumber=biblio.biblionumber
 523             LEFT JOIN biblioitems ON aqorders.biblionumber=biblioitems.biblionumber
 524             WHERE aqbasket.basketno = ?
 525             AND orderstatus IN ('new','ordered')
 526             };
 527
 528             if (!$externalid){
 529                 carp "No basketnumber given";
 530                 return { error => "no_basketno" };
 531             }
 532             $action = "ACQUISITION ORDER";
 533             $sthorders = $dbh->prepare($strsth);
 534             $sthorders->execute($externalid);
 535             $dataorders = $sthorders->fetchall_arrayref( {} );
 536         }
 537
 538         my $sthbookseller =
 539           $dbh->prepare("select * from aqbooksellers where id=?");
 540         $sthbookseller->execute( $dataorders->[0]->{booksellerid} );
 541         my $databookseller = $sthbookseller->fetchrow_hashref;
 542
 543         my $addressee =  $type eq 'claimacquisition' || $type eq 'orderacquisition' ? 'acqprimary' : 'serialsprimary';
 544
 545         my $sthcontact =
 546           $dbh->prepare("SELECT * FROM aqcontacts WHERE booksellerid=? AND $type=1 ORDER BY $addressee DESC");
 547         $sthcontact->execute( $dataorders->[0]->{booksellerid} );
 548         my $datacontact = $sthcontact->fetchrow_hashref;
 549
 550         my @email;
 551         my @cc;
 552         push @email, $databookseller->{bookselleremail} if $databookseller->{bookselleremail};
 553         push @email, $datacontact->{email}           if ( $datacontact && $datacontact->{email} );
 554         unless (@email) {
 555             warn "Bookseller $dataorders->[0]->{booksellerid} without emails";
 556             return { error => "no_email" };
 557         }
 558         my $addlcontact;
 559         while ($addlcontact = $sthcontact->fetchrow_hashref) {
 560             push @cc, $addlcontact->{email} if ( $addlcontact && $addlcontact->{email} );
 561         }
 562
 563         my $userenv = C4::Context->userenv;
 564         my $letter = GetPreparedLetter (
 565             module => $type,
 566             letter_code => $letter_code,
 567             branchcode => $userenv->{branch},
 568             tables => {
 569                 'branches'    => $userenv->{branch},
 570                 'aqbooksellers' => $databookseller,
 571                 'aqcontacts'    => $datacontact,
 572             },
 573             repeat => $dataorders,
 574             want_librarian => 1,
 575         ) or return { error => "no_letter" };
 576
 577         # Remove the order tag
 578         $letter->{content} =~ s/<order>(.*?)<\/order>/$1/gxms;
 579
 580         # ... then send mail
 581         my $library = Koha::Libraries->find( $userenv->{branch} );
 582         my %mail = (
 583             To => join( ',', @email),
 584             Cc             => join( ',', @cc),
 585             From           => $library->branchemail || C4::Context->preference('KohaAdminEmailAddress'),
 586             Subject        => Encode::encode( "UTF-8", "" . $letter->{title} ),
 587             Message => $letter->{'is_html'}
 588                             ? _wrap_html( Encode::encode( "UTF-8", $letter->{'content'} ),
 589                                           Encode::encode( "UTF-8", "" . $letter->{'title'} ))
 590                             : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
 591             'Content-Type' => $letter->{'is_html'}
 592                                 ? 'text/html; charset="utf-8"'
 593                                 : 'text/plain; charset="utf-8"',
 594         );
 595
 596         if ($type eq 'claimacquisition' || $type eq 'claimissues' ) {
 597             $mail{'Reply-to'} = C4::Context->preference('ReplytoDefault')
 598               if C4::Context->preference('ReplytoDefault');
 599             $mail{'Sender'} = C4::Context->preference('ReturnpathDefault')
 600               if C4::Context->preference('ReturnpathDefault');
 601             $mail{'Bcc'} = $userenv->{emailaddress}
 602               if C4::Context->preference("ClaimsBccCopy");
 603         }
 604
 605         unless ( Mail::Sendmail::sendmail(%mail) ) {
 606             carp $Mail::Sendmail::error;
 607             return { error => $Mail::Sendmail::error };
 608         }
 609
 610         logaction(
 611             "ACQUISITION",
 612             $action,
 613             undef,
 614             "To="
 615                 . join( ',', @email )
 616                 . " Title="
 617                 . $letter->{title}
 618                 . " Content="
 619                 . $letter->{content}
 620         ) if C4::Context->preference("LetterLog");
 621     }
 622    # send an "account details" notice to a newly created user
 623     elsif ( $type eq 'members' ) {
 624         my $library = Koha::Libraries->find( $externalid->{branchcode} )->unblessed;
 625         my $letter = GetPreparedLetter (
 626             module => 'members',
 627             letter_code => $letter_code,
 628             branchcode => $externalid->{'branchcode'},
 629             tables => {
 630                 'branches'    => $library,
 631                 'borrowers' => $externalid->{'borrowernumber'},
 632             },
 633             substitute => { 'borrowers.password' => $externalid->{'password'} },
 634             want_librarian => 1,
 635         ) or return;
 636         return { error => "no_email" } unless $externalid->{'emailaddr'};
 637         my $email = Koha::Email->new();
 638         my %mail  = $email->create_message_headers(
 639             {
 640                 to      => $externalid->{'emailaddr'},
 641                 from    => $library->{branchemail},
 642                 replyto => $library->{branchreplyto},
 643                 sender  => $library->{branchreturnpath},
 644                 subject => Encode::encode( "UTF-8", "" . $letter->{'title'} ),
 645                 message => $letter->{'is_html'}
 646                             ? _wrap_html( Encode::encode( "UTF-8", $letter->{'content'} ),
 647                                           Encode::encode( "UTF-8", "" . $letter->{'title'}  ) )
 648                             : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
 649                 contenttype => $letter->{'is_html'}
 650                                 ? 'text/html; charset="utf-8"'
 651                                 : 'text/plain; charset="utf-8"',
 652             }
 653         );
 654         unless( Mail::Sendmail::sendmail(%mail) ) {
 655             carp $Mail::Sendmail::error;
 656             return { error => $Mail::Sendmail::error };
 657         }
 658     }
 659
 660     # If we come here, return an OK status
 661     return 1;
 662 }
 663
 664 =head2 GetPreparedLetter( %params )
 665
 666     %params hash:
 667       module => letter module, mandatory
 668       letter_code => letter code, mandatory
 669       branchcode => for letter selection, if missing default system letter taken
 670       tables => a hashref with table names as keys. Values are either:
 671         - a scalar - primary key value
 672         - an arrayref - primary key values
 673         - a hashref - full record
 674       substitute => custom substitution key/value pairs
 675       repeat => records to be substituted on consecutive lines:
 676         - an arrayref - tries to guess what needs substituting by
 677           taking remaining << >> tokensr; not recommended
 678         - a hashref token => @tables - replaces <token> << >> << >> </token>
 679           subtemplate for each @tables row; table is a hashref as above
 680       want_librarian => boolean,  if set to true triggers librarian details
 681         substitution from the userenv
 682     Return value:
 683       letter fields hashref (title & content useful)
 684
 685 =cut
 686
 687 sub GetPreparedLetter {
 688     my %params = @_;
 689
 690     my $module      = $params{module} or croak "No module";
 691     my $letter_code = $params{letter_code} or croak "No letter_code";
 692     my $branchcode  = $params{branchcode} || '';
 693     my $mtt         = $params{message_transport_type} || 'email';
 694     my $lang        = $params{lang} || 'default';
 695
 696     my $letter = getletter( $module, $letter_code, $branchcode, $mtt, $lang );
 697
 698     unless ( $letter ) {
 699         $letter = getletter( $module, $letter_code, $branchcode, $mtt, 'default' )
 700             or warn( "No $module $letter_code letter transported by " . $mtt ),
 701                return;
 702     }
 703
 704     my $tables = $params{tables} || {};
 705     my $substitute = $params{substitute} || {};
 706     my $loops  = $params{loops} || {}; # loops is not supported for historical notices syntax
 707     my $repeat = $params{repeat};
 708     %$tables || %$substitute || $repeat || %$loops
 709       or carp( "ERROR: nothing to substitute - both 'tables', 'loops' and 'substitute' are empty" ),
 710          return;
 711     my $want_librarian = $params{want_librarian};
 712
 713     if (%$substitute) {
 714         while ( my ($token, $val) = each %$substitute ) {
 715             if ( $token eq 'items.content' ) {
 716                 $val =~ s|\n|<br/>|g if $letter->{is_html};
 717             }
 718
 719             $letter->{title} =~ s/<<$token>>/$val/g;
 720             $letter->{content} =~ s/<<$token>>/$val/g;
 721        }
 722     }
 723
 724     my $OPACBaseURL = C4::Context->preference('OPACBaseURL');
 725     $letter->{content} =~ s/<<OPACBaseURL>>/$OPACBaseURL/go;
 726
 727     if ($want_librarian) {
 728         # parsing librarian name
 729         my $userenv = C4::Context->userenv;
 730         $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/go;
 731         $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/go;
 732         $letter->{content} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/go;
 733     }
 734
 735     my ($repeat_no_enclosing_tags, $repeat_enclosing_tags);
 736
 737     if ($repeat) {
 738         if (ref ($repeat) eq 'ARRAY' ) {
 739             $repeat_no_enclosing_tags = $repeat;
 740         } else {
 741             $repeat_enclosing_tags = $repeat;
 742         }
 743     }
 744
 745     if ($repeat_enclosing_tags) {
 746         while ( my ($tag, $tag_tables) = each %$repeat_enclosing_tags ) {
 747             if ( $letter->{content} =~ m!<$tag>(.*)</$tag>!s ) {
 748                 my $subcontent = $1;
 749                 my @lines = map {
 750                     my %subletter = ( title => '', content => $subcontent );
 751                     _substitute_tables( \%subletter, $_ );
 752                     $subletter{content};
 753                 } @$tag_tables;
 754                 $letter->{content} =~ s!<$tag>.*</$tag>!join( "\n", @lines )!se;
 755             }
 756         }
 757     }
 758
 759     if (%$tables) {
 760         _substitute_tables( $letter, $tables );
 761     }
 762
 763     if ($repeat_no_enclosing_tags) {
 764         if ( $letter->{content} =~ m/[^\n]*<<.*>>[^\n]*/so ) {
 765             my $line = $&;
 766             my $i = 1;
 767             my @lines = map {
 768                 my $c = $line;
 769                 $c =~ s/<<count>>/$i/go;
 770                 foreach my $field ( keys %{$_} ) {
 771                     $c =~ s/(<<[^\.]+.$field>>)/$_->{$field}/;
 772                 }
 773                 $i++;
 774                 $c;
 775             } @$repeat_no_enclosing_tags;
 776
 777             my $replaceby = join( "\n", @lines );
 778             $letter->{content} =~ s/\Q$line\E/$replaceby/s;
 779         }
 780     }
 781
 782     $letter->{content} = _process_tt(
 783         {
 784             content => $letter->{content},
 785             tables  => $tables,
 786             loops  => $loops,
 787             substitute => $substitute,
 788         }
 789     );
 790
 791     $letter->{content} =~ s/<<\S*>>//go; #remove any stragglers
 792
 793     return $letter;
 794 }
 795
 796 sub _substitute_tables {
 797     my ( $letter, $tables ) = @_;
 798     while ( my ($table, $param) = each %$tables ) {
 799         next unless $param;
 800
 801         my $ref = ref $param;
 802
 803         my $values;
 804         if ($ref && $ref eq 'HASH') {
 805             $values = $param;
 806         }
 807         else {
 808             my $sth = _parseletter_sth($table);
 809             unless ($sth) {
 810                 warn "_parseletter_sth('$table') failed to return a valid sth.  No substitution will be done for that table.";
 811                 return;
 812             }
 813             $sth->execute( $ref ? @$param : $param );
 814
 815             $values = $sth->fetchrow_hashref;
 816             $sth->finish();
 817         }
 818
 819         _parseletter ( $letter, $table, $values );
 820     }
 821 }
 822
 823 sub _parseletter_sth {
 824     my $table = shift;
 825     my $sth;
 826     unless ($table) {
 827         carp "ERROR: _parseletter_sth() called without argument (table)";
 828         return;
 829     }
 830     # NOTE: we used to check whether we had a statement handle cached in
 831     #       a %handles module-level variable. This was a dumb move and
 832     #       broke things for the rest of us. prepare_cached is a better
 833     #       way to cache statement handles anyway.
 834     my $query =
 835     ($table eq 'biblio'       )    ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 836     ($table eq 'biblioitems'  )    ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 837     ($table eq 'items'        )    ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 838     ($table eq 'issues'       )    ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 839     ($table eq 'old_issues'   )    ? "SELECT * FROM $table WHERE     itemnumber = ? ORDER BY timestamp DESC LIMIT 1"  :
 840     ($table eq 'reserves'     )    ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?"             :
 841     ($table eq 'borrowers'    )    ? "SELECT * FROM $table WHERE borrowernumber = ?"                                  :
 842     ($table eq 'branches'     )    ? "SELECT * FROM $table WHERE     branchcode = ?"                                  :
 843     ($table eq 'suggestions'  )    ? "SELECT * FROM $table WHERE   suggestionid = ?"                                  :
 844     ($table eq 'aqbooksellers')    ? "SELECT * FROM $table WHERE             id = ?"                                  :
 845     ($table eq 'aqorders'     )    ? "SELECT * FROM $table WHERE    ordernumber = ?"                                  :
 846     ($table eq 'opac_news'    )    ? "SELECT * FROM $table WHERE          idnew = ?"                                  :
 847     ($table eq 'article_requests') ? "SELECT * FROM $table WHERE             id = ?"                                  :
 848     ($table eq 'borrower_modifications') ? "SELECT * FROM $table WHERE verification_token = ?" :
 849     ($table eq 'subscription') ? "SELECT * FROM $table WHERE subscriptionid = ?" :
 850     ($table eq 'serial') ? "SELECT * FROM $table WHERE serialid = ?" :
 851     undef ;
 852     unless ($query) {
 853         warn "ERROR: No _parseletter_sth query for table '$table'";
 854         return;     # nothing to get
 855     }
 856     unless ($sth = C4::Context->dbh->prepare_cached($query)) {
 857         warn "ERROR: Failed to prepare query: '$query'";
 858         return;
 859     }
 860     return $sth;    # now cache is populated for that $table
 861 }
 862
 863 =head2 _parseletter($letter, $table, $values)
 864
 865     parameters :
 866     - $letter : a hash to letter fields (title & content useful)
 867     - $table : the Koha table to parse.
 868     - $values_in : table record hashref
 869     parse all fields from a table, and replace values in title & content with the appropriate value
 870     (not exported sub, used only internally)
 871
 872 =cut
 873
 874 sub _parseletter {
 875     my ( $letter, $table, $values_in ) = @_;
 876
 877     # Work on a local copy of $values_in (passed by reference) to avoid side effects
 878     # in callers ( by changing / formatting values )
 879     my $values = $values_in ? { %$values_in } : {};
 880
 881     if ( $table eq 'borrowers' && $values->{'dateexpiry'} ){
 882         $values->{'dateexpiry'} = format_sqldatetime( $values->{'dateexpiry'} );
 883     }
 884
 885     if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
 886         $values->{'waitingdate'} = output_pref({ dt => dt_from_string( $values->{'waitingdate'} ), dateonly => 1 });
 887     }
 888
 889     if ($letter->{content} && $letter->{content} =~ /<<today>>/) {
 890         my $todaysdate = output_pref( DateTime->now() );
 891         $letter->{content} =~ s/<<today>>/$todaysdate/go;
 892     }
 893
 894     while ( my ($field, $val) = each %$values ) {
 895         $val =~ s/\p{P}$// if $val && $table=~/biblio/;
 896             #BZ 9886: Assuming that we want to eliminate ISBD punctuation here
 897             #Therefore adding the test on biblio. This includes biblioitems,
 898             #but excludes items. Removed unneeded global and lookahead.
 899
 900         if ( $table=~/^borrowers$/ && $field=~/^streettype$/ ) {
 901             my $av = Koha::AuthorisedValues->search({ category => 'ROADTYPE', authorised_value => $val });
 902             $val = $av->count ? $av->next->lib : '';
 903         }
 904
 905         # Dates replacement
 906         my $replacedby   = defined ($val) ? $val : '';
 907         if (    $replacedby
 908             and not $replacedby =~ m|0000-00-00|
 909             and not $replacedby =~ m|9999-12-31|
 910             and $replacedby =~ m|^\d{4}-\d{2}-\d{2}( \d{2}:\d{2}:\d{2})?$| )
 911         {
 912             # If the value is XXXX-YY-ZZ[ AA:BB:CC] we assume it is a date
 913             my $dateonly = defined $1 ? 0 : 1; #$1 refers to the capture group wrapped in parentheses. In this case, that's the hours, minutes, seconds.
 914             my $re_dateonly_filter = qr{ $field( \s* \| \s* dateonly\s*)?>> }xms;
 915
 916             for my $letter_field ( qw( title content ) ) {
 917                 my $filter_string_used = q{};
 918                 if ( $letter->{ $letter_field } =~ $re_dateonly_filter ) {
 919                     # We overwrite $dateonly if the filter exists and we have a time in the datetime
 920                     $filter_string_used = $1 || q{};
 921                     $dateonly = $1 unless $dateonly;
 922                 }
 923                 my $replacedby_date = eval {
 924                     output_pref({ dt => dt_from_string( $replacedby ), dateonly => $dateonly });
 925                 };
 926
 927                 if ( $letter->{ $letter_field } ) {
 928                     $letter->{ $letter_field } =~ s/\Q<<$table.$field$filter_string_used>>\E/$replacedby_date/g;
 929                     $letter->{ $letter_field } =~ s/\Q<<$field$filter_string_used>>\E/$replacedby_date/g;
 930                 }
 931             }
 932         }
 933         # Other fields replacement
 934         else {
 935             for my $letter_field ( qw( title content ) ) {
 936                 if ( $letter->{ $letter_field } ) {
 937                     $letter->{ $letter_field }   =~ s/<<$table.$field>>/$replacedby/g;
 938                     $letter->{ $letter_field }   =~ s/<<$field>>/$replacedby/g;
 939                 }
 940             }
 941         }
 942     }
 943
 944     if ($table eq 'borrowers' && $letter->{content}) {
 945         if ( my $attributes = GetBorrowerAttributes($values->{borrowernumber}) ) {
 946             my %attr;
 947             foreach (@$attributes) {
 948                 my $code = $_->{code};
 949                 my $val  = $_->{value_description} || $_->{value};
 950                 $val =~ s/\p{P}(?=$)//g if $val;
 951                 next unless $val gt '';
 952                 $attr{$code} ||= [];
 953                 push @{ $attr{$code} }, $val;
 954             }
 955             while ( my ($code, $val_ar) = each %attr ) {
 956                 my $replacefield = "<<borrower-attribute:$code>>";
 957                 my $replacedby   = join ',', @$val_ar;
 958                 $letter->{content} =~ s/$replacefield/$replacedby/g;
 959             }
 960         }
 961     }
 962     return $letter;
 963 }
 964
 965 =head2 EnqueueLetter
 966
 967   my $success = EnqueueLetter( { letter => $letter,
 968         borrowernumber => '12', message_transport_type => 'email' } )
 969
 970 places a letter in the message_queue database table, which will
 971 eventually get processed (sent) by the process_message_queue.pl
 972 cronjob when it calls SendQueuedMessages.
 973
 974 return message_id on success
 975
 976 =cut
 977
 978 sub EnqueueLetter {
 979     my $params = shift or return;
 980
 981     return unless exists $params->{'letter'};
 982 #   return unless exists $params->{'borrowernumber'};
 983     return unless exists $params->{'message_transport_type'};
 984
 985     my $content = $params->{letter}->{content};
 986     $content =~ s/\s+//g if(defined $content);
 987     if ( not defined $content or $content eq '' ) {
 988         warn "Trying to add an empty message to the message queue" if $debug;
 989         return;
 990     }
 991
 992     # If we have any attachments we should encode then into the body.
 993     if ( $params->{'attachments'} ) {
 994         $params->{'letter'} = _add_attachments(
 995             {   letter      => $params->{'letter'},
 996                 attachments => $params->{'attachments'},
 997                 message     => MIME::Lite->new( Type => 'multipart/mixed' ),
 998             }
 999         );
1000     }
1001
1002     my $dbh       = C4::Context->dbh();
1003     my $statement = << 'ENDSQL';
1004 INSERT INTO message_queue
1005 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type )
1006 VALUES
1007 ( ?,              ?,       ?,       ?,        ?,           ?,                      ?,      NOW(),       ?,          ?,            ? )
1008 ENDSQL
1009
1010     my $sth    = $dbh->prepare($statement);
1011     my $result = $sth->execute(
1012         $params->{'borrowernumber'},              # borrowernumber
1013         $params->{'letter'}->{'title'},           # subject
1014         $params->{'letter'}->{'content'},         # content
1015         $params->{'letter'}->{'metadata'} || '',  # metadata
1016         $params->{'letter'}->{'code'}     || '',  # letter_code
1017         $params->{'message_transport_type'},      # message_transport_type
1018         'pending',                                # status
1019         $params->{'to_address'},                  # to_address
1020         $params->{'from_address'},                # from_address
1021         $params->{'letter'}->{'content-type'},    # content_type
1022     );
1023     return $dbh->last_insert_id(undef,undef,'message_queue', undef);
1024 }
1025
1026 =head2 SendQueuedMessages ([$hashref])
1027
1028     my $sent = SendQueuedMessages({
1029         letter_code => $letter_code,
1030         borrowernumber => $who_letter_is_for,
1031         limit => 50,
1032         verbose => 1,
1033         type => 'sms',
1034     });
1035
1036 Sends all of the 'pending' items in the message queue, unless
1037 parameters are passed.
1038
1039 The letter_code, borrowernumber and limit parameters are used
1040 to build a parameter set for _get_unsent_messages, thus limiting
1041 which pending messages will be processed. They are all optional.
1042
1043 The verbose parameter can be used to generate debugging output.
1044 It is also optional.
1045
1046 Returns number of messages sent.
1047
1048 =cut
1049
1050 sub SendQueuedMessages {
1051     my $params = shift;
1052
1053     my $which_unsent_messages  = {
1054         'limit'          => $params->{'limit'} // 0,
1055         'borrowernumber' => $params->{'borrowernumber'} // q{},
1056         'letter_code'    => $params->{'letter_code'} // q{},
1057         'type'           => $params->{'type'} // q{},
1058     };
1059     my $unsent_messages = _get_unsent_messages( $which_unsent_messages );
1060     MESSAGE: foreach my $message ( @$unsent_messages ) {
1061         my $message_object = Koha::Notice::Messages->find( $message->{message_id} );
1062         # If this fails the database is unwritable and we won't manage to send a message that continues to be marked 'pending'
1063         $message_object->make_column_dirty('status');
1064         return unless $message_object->store;
1065
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 = C4::Members::GetNoticeEmailAddress( $message->{'borrowernumber'} );
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__