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             lang       => $externalid->{lang} || 'default',
 630             tables => {
 631                 'branches'    => $library,
 632                 'borrowers' => $externalid->{'borrowernumber'},
 633             },
 634             substitute => { 'borrowers.password' => $externalid->{'password'} },
 635             want_librarian => 1,
 636         ) or return;
 637         return { error => "no_email" } unless $externalid->{'emailaddr'};
 638         my $email = Koha::Email->new();
 639         my %mail  = $email->create_message_headers(
 640             {
 641                 to      => $externalid->{'emailaddr'},
 642                 from    => $library->{branchemail},
 643                 replyto => $library->{branchreplyto},
 644                 sender  => $library->{branchreturnpath},
 645                 subject => Encode::encode( "UTF-8", "" . $letter->{'title'} ),
 646                 message => $letter->{'is_html'}
 647                             ? _wrap_html( Encode::encode( "UTF-8", $letter->{'content'} ),
 648                                           Encode::encode( "UTF-8", "" . $letter->{'title'}  ) )
 649                             : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
 650                 contenttype => $letter->{'is_html'}
 651                                 ? 'text/html; charset="utf-8"'
 652                                 : 'text/plain; charset="utf-8"',
 653             }
 654         );
 655         unless( Mail::Sendmail::sendmail(%mail) ) {
 656             carp $Mail::Sendmail::error;
 657             return { error => $Mail::Sendmail::error };
 658         }
 659     }
 660
 661     # If we come here, return an OK status
 662     return 1;
 663 }
 664
 665 =head2 GetPreparedLetter( %params )
 666
 667     %params hash:
 668       module => letter module, mandatory
 669       letter_code => letter code, mandatory
 670       branchcode => for letter selection, if missing default system letter taken
 671       tables => a hashref with table names as keys. Values are either:
 672         - a scalar - primary key value
 673         - an arrayref - primary key values
 674         - a hashref - full record
 675       substitute => custom substitution key/value pairs
 676       repeat => records to be substituted on consecutive lines:
 677         - an arrayref - tries to guess what needs substituting by
 678           taking remaining << >> tokensr; not recommended
 679         - a hashref token => @tables - replaces <token> << >> << >> </token>
 680           subtemplate for each @tables row; table is a hashref as above
 681       want_librarian => boolean,  if set to true triggers librarian details
 682         substitution from the userenv
 683     Return value:
 684       letter fields hashref (title & content useful)
 685
 686 =cut
 687
 688 sub GetPreparedLetter {
 689     my %params = @_;
 690
 691     my $module      = $params{module} or croak "No module";
 692     my $letter_code = $params{letter_code} or croak "No letter_code";
 693     my $branchcode  = $params{branchcode} || '';
 694     my $mtt         = $params{message_transport_type} || 'email';
 695     my $lang        = $params{lang} || 'default';
 696
 697     my $letter = getletter( $module, $letter_code, $branchcode, $mtt, $lang );
 698
 699     unless ( $letter ) {
 700         $letter = getletter( $module, $letter_code, $branchcode, $mtt, 'default' )
 701             or warn( "No $module $letter_code letter transported by " . $mtt ),
 702                return;
 703     }
 704
 705     my $tables = $params{tables} || {};
 706     my $substitute = $params{substitute} || {};
 707     my $loops  = $params{loops} || {}; # loops is not supported for historical notices syntax
 708     my $repeat = $params{repeat};
 709     %$tables || %$substitute || $repeat || %$loops
 710       or carp( "ERROR: nothing to substitute - both 'tables', 'loops' and 'substitute' are empty" ),
 711          return;
 712     my $want_librarian = $params{want_librarian};
 713
 714     if (%$substitute) {
 715         while ( my ($token, $val) = each %$substitute ) {
 716             if ( $token eq 'items.content' ) {
 717                 $val =~ s|\n|<br/>|g if $letter->{is_html};
 718             }
 719
 720             $letter->{title} =~ s/<<$token>>/$val/g;
 721             $letter->{content} =~ s/<<$token>>/$val/g;
 722        }
 723     }
 724
 725     my $OPACBaseURL = C4::Context->preference('OPACBaseURL');
 726     $letter->{content} =~ s/<<OPACBaseURL>>/$OPACBaseURL/go;
 727
 728     if ($want_librarian) {
 729         # parsing librarian name
 730         my $userenv = C4::Context->userenv;
 731         $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/go;
 732         $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/go;
 733         $letter->{content} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/go;
 734     }
 735
 736     my ($repeat_no_enclosing_tags, $repeat_enclosing_tags);
 737
 738     if ($repeat) {
 739         if (ref ($repeat) eq 'ARRAY' ) {
 740             $repeat_no_enclosing_tags = $repeat;
 741         } else {
 742             $repeat_enclosing_tags = $repeat;
 743         }
 744     }
 745
 746     if ($repeat_enclosing_tags) {
 747         while ( my ($tag, $tag_tables) = each %$repeat_enclosing_tags ) {
 748             if ( $letter->{content} =~ m!<$tag>(.*)</$tag>!s ) {
 749                 my $subcontent = $1;
 750                 my @lines = map {
 751                     my %subletter = ( title => '', content => $subcontent );
 752                     _substitute_tables( \%subletter, $_ );
 753                     $subletter{content};
 754                 } @$tag_tables;
 755                 $letter->{content} =~ s!<$tag>.*</$tag>!join( "\n", @lines )!se;
 756             }
 757         }
 758     }
 759
 760     if (%$tables) {
 761         _substitute_tables( $letter, $tables );
 762     }
 763
 764     if ($repeat_no_enclosing_tags) {
 765         if ( $letter->{content} =~ m/[^\n]*<<.*>>[^\n]*/so ) {
 766             my $line = $&;
 767             my $i = 1;
 768             my @lines = map {
 769                 my $c = $line;
 770                 $c =~ s/<<count>>/$i/go;
 771                 foreach my $field ( keys %{$_} ) {
 772                     $c =~ s/(<<[^\.]+.$field>>)/$_->{$field}/;
 773                 }
 774                 $i++;
 775                 $c;
 776             } @$repeat_no_enclosing_tags;
 777
 778             my $replaceby = join( "\n", @lines );
 779             $letter->{content} =~ s/\Q$line\E/$replaceby/s;
 780         }
 781     }
 782
 783     $letter->{content} = _process_tt(
 784         {
 785             content => $letter->{content},
 786             tables  => $tables,
 787             loops  => $loops,
 788             substitute => $substitute,
 789         }
 790     );
 791
 792     $letter->{content} =~ s/<<\S*>>//go; #remove any stragglers
 793
 794     return $letter;
 795 }
 796
 797 sub _substitute_tables {
 798     my ( $letter, $tables ) = @_;
 799     while ( my ($table, $param) = each %$tables ) {
 800         next unless $param;
 801
 802         my $ref = ref $param;
 803
 804         my $values;
 805         if ($ref && $ref eq 'HASH') {
 806             $values = $param;
 807         }
 808         else {
 809             my $sth = _parseletter_sth($table);
 810             unless ($sth) {
 811                 warn "_parseletter_sth('$table') failed to return a valid sth.  No substitution will be done for that table.";
 812                 return;
 813             }
 814             $sth->execute( $ref ? @$param : $param );
 815
 816             $values = $sth->fetchrow_hashref;
 817             $sth->finish();
 818         }
 819
 820         _parseletter ( $letter, $table, $values );
 821     }
 822 }
 823
 824 sub _parseletter_sth {
 825     my $table = shift;
 826     my $sth;
 827     unless ($table) {
 828         carp "ERROR: _parseletter_sth() called without argument (table)";
 829         return;
 830     }
 831     # NOTE: we used to check whether we had a statement handle cached in
 832     #       a %handles module-level variable. This was a dumb move and
 833     #       broke things for the rest of us. prepare_cached is a better
 834     #       way to cache statement handles anyway.
 835     my $query =
 836     ($table eq 'biblio'       )    ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 837     ($table eq 'biblioitems'  )    ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 838     ($table eq 'items'        )    ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 839     ($table eq 'issues'       )    ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 840     ($table eq 'old_issues'   )    ? "SELECT * FROM $table WHERE     itemnumber = ? ORDER BY timestamp DESC LIMIT 1"  :
 841     ($table eq 'reserves'     )    ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?"             :
 842     ($table eq 'borrowers'    )    ? "SELECT * FROM $table WHERE borrowernumber = ?"                                  :
 843     ($table eq 'branches'     )    ? "SELECT * FROM $table WHERE     branchcode = ?"                                  :
 844     ($table eq 'suggestions'  )    ? "SELECT * FROM $table WHERE   suggestionid = ?"                                  :
 845     ($table eq 'aqbooksellers')    ? "SELECT * FROM $table WHERE             id = ?"                                  :
 846     ($table eq 'aqorders'     )    ? "SELECT * FROM $table WHERE    ordernumber = ?"                                  :
 847     ($table eq 'opac_news'    )    ? "SELECT * FROM $table WHERE          idnew = ?"                                  :
 848     ($table eq 'article_requests') ? "SELECT * FROM $table WHERE             id = ?"                                  :
 849     ($table eq 'borrower_modifications') ? "SELECT * FROM $table WHERE verification_token = ?" :
 850     ($table eq 'subscription') ? "SELECT * FROM $table WHERE subscriptionid = ?" :
 851     ($table eq 'serial') ? "SELECT * FROM $table WHERE serialid = ?" :
 852     undef ;
 853     unless ($query) {
 854         warn "ERROR: No _parseletter_sth query for table '$table'";
 855         return;     # nothing to get
 856     }
 857     unless ($sth = C4::Context->dbh->prepare_cached($query)) {
 858         warn "ERROR: Failed to prepare query: '$query'";
 859         return;
 860     }
 861     return $sth;    # now cache is populated for that $table
 862 }
 863
 864 =head2 _parseletter($letter, $table, $values)
 865
 866     parameters :
 867     - $letter : a hash to letter fields (title & content useful)
 868     - $table : the Koha table to parse.
 869     - $values_in : table record hashref
 870     parse all fields from a table, and replace values in title & content with the appropriate value
 871     (not exported sub, used only internally)
 872
 873 =cut
 874
 875 sub _parseletter {
 876     my ( $letter, $table, $values_in ) = @_;
 877
 878     # Work on a local copy of $values_in (passed by reference) to avoid side effects
 879     # in callers ( by changing / formatting values )
 880     my $values = $values_in ? { %$values_in } : {};
 881
 882     if ( $table eq 'borrowers' && $values->{'dateexpiry'} ){
 883         $values->{'dateexpiry'} = format_sqldatetime( $values->{'dateexpiry'} );
 884     }
 885
 886     if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
 887         $values->{'waitingdate'} = output_pref({ dt => dt_from_string( $values->{'waitingdate'} ), dateonly => 1 });
 888     }
 889
 890     if ($letter->{content} && $letter->{content} =~ /<<today>>/) {
 891         my $todaysdate = output_pref( DateTime->now() );
 892         $letter->{content} =~ s/<<today>>/$todaysdate/go;
 893     }
 894
 895     while ( my ($field, $val) = each %$values ) {
 896         $val =~ s/\p{P}$// if $val && $table=~/biblio/;
 897             #BZ 9886: Assuming that we want to eliminate ISBD punctuation here
 898             #Therefore adding the test on biblio. This includes biblioitems,
 899             #but excludes items. Removed unneeded global and lookahead.
 900
 901         if ( $table=~/^borrowers$/ && $field=~/^streettype$/ ) {
 902             my $av = Koha::AuthorisedValues->search({ category => 'ROADTYPE', authorised_value => $val });
 903             $val = $av->count ? $av->next->lib : '';
 904         }
 905
 906         # Dates replacement
 907         my $replacedby   = defined ($val) ? $val : '';
 908         if (    $replacedby
 909             and not $replacedby =~ m|0000-00-00|
 910             and not $replacedby =~ m|9999-12-31|
 911             and $replacedby =~ m|^\d{4}-\d{2}-\d{2}( \d{2}:\d{2}:\d{2})?$| )
 912         {
 913             # If the value is XXXX-YY-ZZ[ AA:BB:CC] we assume it is a date
 914             my $dateonly = defined $1 ? 0 : 1; #$1 refers to the capture group wrapped in parentheses. In this case, that's the hours, minutes, seconds.
 915             my $re_dateonly_filter = qr{ $field( \s* \| \s* dateonly\s*)?>> }xms;
 916
 917             for my $letter_field ( qw( title content ) ) {
 918                 my $filter_string_used = q{};
 919                 if ( $letter->{ $letter_field } =~ $re_dateonly_filter ) {
 920                     # We overwrite $dateonly if the filter exists and we have a time in the datetime
 921                     $filter_string_used = $1 || q{};
 922                     $dateonly = $1 unless $dateonly;
 923                 }
 924                 my $replacedby_date = eval {
 925                     output_pref({ dt => dt_from_string( $replacedby ), dateonly => $dateonly });
 926                 };
 927
 928                 if ( $letter->{ $letter_field } ) {
 929                     $letter->{ $letter_field } =~ s/\Q<<$table.$field$filter_string_used>>\E/$replacedby_date/g;
 930                     $letter->{ $letter_field } =~ s/\Q<<$field$filter_string_used>>\E/$replacedby_date/g;
 931                 }
 932             }
 933         }
 934         # Other fields replacement
 935         else {
 936             for my $letter_field ( qw( title content ) ) {
 937                 if ( $letter->{ $letter_field } ) {
 938                     $letter->{ $letter_field }   =~ s/<<$table.$field>>/$replacedby/g;
 939                     $letter->{ $letter_field }   =~ s/<<$field>>/$replacedby/g;
 940                 }
 941             }
 942         }
 943     }
 944
 945     if ($table eq 'borrowers' && $letter->{content}) {
 946         if ( my $attributes = GetBorrowerAttributes($values->{borrowernumber}) ) {
 947             my %attr;
 948             foreach (@$attributes) {
 949                 my $code = $_->{code};
 950                 my $val  = $_->{value_description} || $_->{value};
 951                 $val =~ s/\p{P}(?=$)//g if $val;
 952                 next unless $val gt '';
 953                 $attr{$code} ||= [];
 954                 push @{ $attr{$code} }, $val;
 955             }
 956             while ( my ($code, $val_ar) = each %attr ) {
 957                 my $replacefield = "<<borrower-attribute:$code>>";
 958                 my $replacedby   = join ',', @$val_ar;
 959                 $letter->{content} =~ s/$replacefield/$replacedby/g;
 960             }
 961         }
 962     }
 963     return $letter;
 964 }
 965
 966 =head2 EnqueueLetter
 967
 968   my $success = EnqueueLetter( { letter => $letter,
 969         borrowernumber => '12', message_transport_type => 'email' } )
 970
 971 places a letter in the message_queue database table, which will
 972 eventually get processed (sent) by the process_message_queue.pl
 973 cronjob when it calls SendQueuedMessages.
 974
 975 return message_id on success
 976
 977 =cut
 978
 979 sub EnqueueLetter {
 980     my $params = shift or return;
 981
 982     return unless exists $params->{'letter'};
 983 #   return unless exists $params->{'borrowernumber'};
 984     return unless exists $params->{'message_transport_type'};
 985
 986     my $content = $params->{letter}->{content};
 987     $content =~ s/\s+//g if(defined $content);
 988     if ( not defined $content or $content eq '' ) {
 989         warn "Trying to add an empty message to the message queue" if $debug;
 990         return;
 991     }
 992
 993     # If we have any attachments we should encode then into the body.
 994     if ( $params->{'attachments'} ) {
 995         $params->{'letter'} = _add_attachments(
 996             {   letter      => $params->{'letter'},
 997                 attachments => $params->{'attachments'},
 998                 message     => MIME::Lite->new( Type => 'multipart/mixed' ),
 999             }
1000         );
1001     }
1002
1003     my $dbh       = C4::Context->dbh();
1004     my $statement = << 'ENDSQL';
1005 INSERT INTO message_queue
1006 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type )
1007 VALUES
1008 ( ?,              ?,       ?,       ?,        ?,           ?,                      ?,      NOW(),       ?,          ?,            ? )
1009 ENDSQL
1010
1011     my $sth    = $dbh->prepare($statement);
1012     my $result = $sth->execute(
1013         $params->{'borrowernumber'},              # borrowernumber
1014         $params->{'letter'}->{'title'},           # subject
1015         $params->{'letter'}->{'content'},         # content
1016         $params->{'letter'}->{'metadata'} || '',  # metadata
1017         $params->{'letter'}->{'code'}     || '',  # letter_code
1018         $params->{'message_transport_type'},      # message_transport_type
1019         'pending',                                # status
1020         $params->{'to_address'},                  # to_address
1021         $params->{'from_address'},                # from_address
1022         $params->{'letter'}->{'content-type'},    # content_type
1023     );
1024     return $dbh->last_insert_id(undef,undef,'message_queue', undef);
1025 }
1026
1027 =head2 SendQueuedMessages ([$hashref])
1028
1029     my $sent = SendQueuedMessages({
1030         letter_code => $letter_code,
1031         borrowernumber => $who_letter_is_for,
1032         limit => 50,
1033         verbose => 1,
1034         type => 'sms',
1035     });
1036
1037 Sends all of the 'pending' items in the message queue, unless
1038 parameters are passed.
1039
1040 The letter_code, borrowernumber and limit parameters are used
1041 to build a parameter set for _get_unsent_messages, thus limiting
1042 which pending messages will be processed. They are all optional.
1043
1044 The verbose parameter can be used to generate debugging output.
1045 It is also optional.
1046
1047 Returns number of messages sent.
1048
1049 =cut
1050
1051 sub SendQueuedMessages {
1052     my $params = shift;
1053
1054     my $which_unsent_messages  = {
1055         'limit'          => $params->{'limit'} // 0,
1056         'borrowernumber' => $params->{'borrowernumber'} // q{},
1057         'letter_code'    => $params->{'letter_code'} // q{},
1058         'type'           => $params->{'type'} // q{},
1059     };
1060     my $unsent_messages = _get_unsent_messages( $which_unsent_messages );
1061     MESSAGE: foreach my $message ( @$unsent_messages ) {
1062         my $message_object = Koha::Notice::Messages->find( $message->{message_id} );
1063         # If this fails the database is unwritable and we won't manage to send a message that continues to be marked 'pending'
1064         $message_object->make_column_dirty('status');
1065         return unless $message_object->store;
1066
1067         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
1068         warn sprintf( 'sending %s message to patron: %s',
1069                       $message->{'message_transport_type'},
1070                       $message->{'borrowernumber'} || 'Admin' )
1071           if $params->{'verbose'} or $debug;
1072         # This is just begging for subclassing
1073         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
1074         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
1075             _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
1076         }
1077         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
1078             if ( C4::Context->preference('SMSSendDriver') eq 'Email' ) {
1079                 my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1080                 my $sms_provider = Koha::SMS::Providers->find( $patron->sms_provider_id );
1081                 unless ( $sms_provider ) {
1082                     warn sprintf( "Patron %s has no sms provider id set!", $message->{'borrowernumber'} ) if $params->{'verbose'} or $debug;
1083                     _set_message_status( { message_id => $message->{'message_id'}, status => 'failed' } );
1084                     next MESSAGE;
1085                 }
1086                 unless ( $patron->smsalertnumber ) {
1087                     _set_message_status( { message_id => $message->{'message_id'}, status => 'failed' } );
1088                     warn sprintf( "No smsalertnumber found for patron %s!", $message->{'borrowernumber'} ) if $params->{'verbose'} or $debug;
1089                     next MESSAGE;
1090                 }
1091                 $message->{to_address}  = $patron->smsalertnumber; #Sometime this is set to email - sms should always use smsalertnumber
1092                 $message->{to_address} .= '@' . $sms_provider->domain();
1093                 _update_message_to_address($message->{'message_id'},$message->{to_address});
1094                 _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
1095             } else {
1096                 _send_message_by_sms( $message );
1097             }
1098         }
1099     }
1100     return scalar( @$unsent_messages );
1101 }
1102
1103 =head2 GetRSSMessages
1104
1105   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
1106
1107 returns a listref of all queued RSS messages for a particular person.
1108
1109 =cut
1110
1111 sub GetRSSMessages {
1112     my $params = shift;
1113
1114     return unless $params;
1115     return unless ref $params;
1116     return unless $params->{'borrowernumber'};
1117
1118     return _get_unsent_messages( { message_transport_type => 'rss',
1119                                    limit                  => $params->{'limit'},
1120                                    borrowernumber         => $params->{'borrowernumber'}, } );
1121 }
1122
1123 =head2 GetPrintMessages
1124
1125   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
1126
1127 Returns a arrayref of all queued print messages (optionally, for a particular
1128 person).
1129
1130 =cut
1131
1132 sub GetPrintMessages {
1133     my $params = shift || {};
1134
1135     return _get_unsent_messages( { message_transport_type => 'print',
1136                                    borrowernumber         => $params->{'borrowernumber'},
1137                                  } );
1138 }
1139
1140 =head2 GetQueuedMessages ([$hashref])
1141
1142   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
1143
1144 fetches messages out of the message queue.
1145
1146 returns:
1147 list of hashes, each has represents a message in the message queue.
1148
1149 =cut
1150
1151 sub GetQueuedMessages {
1152     my $params = shift;
1153
1154     my $dbh = C4::Context->dbh();
1155     my $statement = << 'ENDSQL';
1156 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued
1157 FROM message_queue
1158 ENDSQL
1159
1160     my @query_params;
1161     my @whereclauses;
1162     if ( exists $params->{'borrowernumber'} ) {
1163         push @whereclauses, ' borrowernumber = ? ';
1164         push @query_params, $params->{'borrowernumber'};
1165     }
1166
1167     if ( @whereclauses ) {
1168         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
1169     }
1170
1171     if ( defined $params->{'limit'} ) {
1172         $statement .= ' LIMIT ? ';
1173         push @query_params, $params->{'limit'};
1174     }
1175
1176     my $sth = $dbh->prepare( $statement );
1177     my $result = $sth->execute( @query_params );
1178     return $sth->fetchall_arrayref({});
1179 }
1180
1181 =head2 GetMessageTransportTypes
1182
1183   my @mtt = GetMessageTransportTypes();
1184
1185   returns an arrayref of transport types
1186
1187 =cut
1188
1189 sub GetMessageTransportTypes {
1190     my $dbh = C4::Context->dbh();
1191     my $mtts = $dbh->selectcol_arrayref("
1192         SELECT message_transport_type
1193         FROM message_transport_types
1194         ORDER BY message_transport_type
1195     ");
1196     return $mtts;
1197 }
1198
1199 =head2 GetMessage
1200
1201     my $message = C4::Letters::Message($message_id);
1202
1203 =cut
1204
1205 sub GetMessage {
1206     my ( $message_id ) = @_;
1207     return unless $message_id;
1208     my $dbh = C4::Context->dbh;
1209     return $dbh->selectrow_hashref(q|
1210         SELECT message_id, borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type
1211         FROM message_queue
1212         WHERE message_id = ?
1213     |, {}, $message_id );
1214 }
1215
1216 =head2 ResendMessage
1217
1218   Attempt to resend a message which has failed previously.
1219
1220   my $has_been_resent = C4::Letters::ResendMessage($message_id);
1221
1222   Updates the message to 'pending' status so that
1223   it will be resent later on.
1224
1225   returns 1 on success, 0 on failure, undef if no message was found
1226
1227 =cut
1228
1229 sub ResendMessage {
1230     my $message_id = shift;
1231     return unless $message_id;
1232
1233     my $message = GetMessage( $message_id );
1234     return unless $message;
1235     my $rv = 0;
1236     if ( $message->{status} ne 'pending' ) {
1237         $rv = C4::Letters::_set_message_status({
1238             message_id => $message_id,
1239             status => 'pending',
1240         });
1241         $rv = $rv > 0? 1: 0;
1242         # Clear destination email address to force address update
1243         _update_message_to_address( $message_id, undef ) if $rv &&
1244             $message->{message_transport_type} eq 'email';
1245     }
1246     return $rv;
1247 }
1248
1249 =head2 _add_attachements
1250
1251   named parameters:
1252   letter - the standard letter hashref
1253   attachments - listref of attachments. each attachment is a hashref of:
1254     type - the mime type, like 'text/plain'
1255     content - the actual attachment
1256     filename - the name of the attachment.
1257   message - a MIME::Lite object to attach these to.
1258
1259   returns your letter object, with the content updated.
1260
1261 =cut
1262
1263 sub _add_attachments {
1264     my $params = shift;
1265
1266     my $letter = $params->{'letter'};
1267     my $attachments = $params->{'attachments'};
1268     return $letter unless @$attachments;
1269     my $message = $params->{'message'};
1270
1271     # First, we have to put the body in as the first attachment
1272     $message->attach(
1273         Type => $letter->{'content-type'} || 'TEXT',
1274         Data => $letter->{'is_html'}
1275             ? _wrap_html($letter->{'content'}, $letter->{'title'})
1276             : $letter->{'content'},
1277     );
1278
1279     foreach my $attachment ( @$attachments ) {
1280         $message->attach(
1281             Type     => $attachment->{'type'},
1282             Data     => $attachment->{'content'},
1283             Filename => $attachment->{'filename'},
1284         );
1285     }
1286     # we're forcing list context here to get the header, not the count back from grep.
1287     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
1288     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
1289     $letter->{'content'} = $message->body_as_string;
1290
1291     return $letter;
1292
1293 }
1294
1295 =head2 _get_unsent_messages
1296
1297   This function's parameter hash reference takes the following
1298   optional named parameters:
1299    message_transport_type: method of message sending (e.g. email, sms, etc.)
1300    borrowernumber        : who the message is to be sent
1301    letter_code           : type of message being sent (e.g. PASSWORD_RESET)
1302    limit                 : maximum number of messages to send
1303
1304   This function returns an array of matching hash referenced rows from
1305   message_queue with some borrower information added.
1306
1307 =cut
1308
1309 sub _get_unsent_messages {
1310     my $params = shift;
1311
1312     my $dbh = C4::Context->dbh();
1313     my $statement = qq{
1314         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
1315         FROM message_queue mq
1316         LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
1317         WHERE status = ?
1318     };
1319
1320     my @query_params = ('pending');
1321     if ( ref $params ) {
1322         if ( $params->{'message_transport_type'} ) {
1323             $statement .= ' AND mq.message_transport_type = ? ';
1324             push @query_params, $params->{'message_transport_type'};
1325         }
1326         if ( $params->{'borrowernumber'} ) {
1327             $statement .= ' AND mq.borrowernumber = ? ';
1328             push @query_params, $params->{'borrowernumber'};
1329         }
1330         if ( $params->{'letter_code'} ) {
1331             $statement .= ' AND mq.letter_code = ? ';
1332             push @query_params, $params->{'letter_code'};
1333         }
1334         if ( $params->{'type'} ) {
1335             $statement .= ' AND message_transport_type = ? ';
1336             push @query_params, $params->{'type'};
1337         }
1338         if ( $params->{'limit'} ) {
1339             $statement .= ' limit ? ';
1340             push @query_params, $params->{'limit'};
1341         }
1342     }
1343
1344     $debug and warn "_get_unsent_messages SQL: $statement";
1345     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
1346     my $sth = $dbh->prepare( $statement );
1347     my $result = $sth->execute( @query_params );
1348     return $sth->fetchall_arrayref({});
1349 }
1350
1351 sub _send_message_by_email {
1352     my $message = shift or return;
1353     my ($username, $password, $method) = @_;
1354
1355     my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1356     my $to_address = $message->{'to_address'};
1357     unless ($to_address) {
1358         unless ($patron) {
1359             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
1360             _set_message_status( { message_id => $message->{'message_id'},
1361                                    status     => 'failed' } );
1362             return;
1363         }
1364         $to_address = C4::Members::GetNoticeEmailAddress( $message->{'borrowernumber'} );
1365         unless ($to_address) {
1366             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
1367             # warning too verbose for this more common case?
1368             _set_message_status( { message_id => $message->{'message_id'},
1369                                    status     => 'failed' } );
1370             return;
1371         }
1372     }
1373
1374     my $utf8   = decode('MIME-Header', $message->{'subject'} );
1375     $message->{subject}= encode('MIME-Header', $utf8);
1376     my $subject = encode('UTF-8', $message->{'subject'});
1377     my $content = encode('UTF-8', $message->{'content'});
1378     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
1379     my $is_html = $content_type =~ m/html/io;
1380     my $branch_email = undef;
1381     my $branch_replyto = undef;
1382     my $branch_returnpath = undef;
1383     if ($patron) {
1384         my $library = $patron->library;
1385         $branch_email      = $library->branchemail;
1386         $branch_replyto    = $library->branchreplyto;
1387         $branch_returnpath = $library->branchreturnpath;
1388     }
1389     my $email = Koha::Email->new();
1390     my %sendmail_params = $email->create_message_headers(
1391         {
1392             to      => $to_address,
1393             from    => $message->{'from_address'} || $branch_email,
1394             replyto => $branch_replyto,
1395             sender  => $branch_returnpath,
1396             subject => $subject,
1397             message => $is_html ? _wrap_html( $content, $subject ) : $content,
1398             contenttype => $content_type
1399         }
1400     );
1401
1402     $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
1403     if ( my $bcc = C4::Context->preference('NoticeBcc') ) {
1404        $sendmail_params{ Bcc } = $bcc;
1405     }
1406
1407     _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
1408
1409     if ( Mail::Sendmail::sendmail( %sendmail_params ) ) {
1410         _set_message_status( { message_id => $message->{'message_id'},
1411                 status     => 'sent' } );
1412         return 1;
1413     } else {
1414         _set_message_status( { message_id => $message->{'message_id'},
1415                 status     => 'failed' } );
1416         carp $Mail::Sendmail::error;
1417         return;
1418     }
1419 }
1420
1421 sub _wrap_html {
1422     my ($content, $title) = @_;
1423
1424     my $css = C4::Context->preference("NoticeCSS") || '';
1425     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
1426     return <<EOS;
1427 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1428     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1429 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1430 <head>
1431 <title>$title</title>
1432 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1433 $css
1434 </head>
1435 <body>
1436 $content
1437 </body>
1438 </html>
1439 EOS
1440 }
1441
1442 sub _is_duplicate {
1443     my ( $message ) = @_;
1444     my $dbh = C4::Context->dbh;
1445     my $count = $dbh->selectrow_array(q|
1446         SELECT COUNT(*)
1447         FROM message_queue
1448         WHERE message_transport_type = ?
1449         AND borrowernumber = ?
1450         AND letter_code = ?
1451         AND CAST(time_queued AS date) = CAST(NOW() AS date)
1452         AND status="sent"
1453         AND content = ?
1454     |, {}, $message->{message_transport_type}, $message->{borrowernumber}, $message->{letter_code}, $message->{content} );
1455     return $count;
1456 }
1457
1458 sub _send_message_by_sms {
1459     my $message = shift or return;
1460     my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1461
1462     unless ( $patron and $patron->smsalertnumber ) {
1463         _set_message_status( { message_id => $message->{'message_id'},
1464                                status     => 'failed' } );
1465         return;
1466     }
1467
1468     if ( _is_duplicate( $message ) ) {
1469         _set_message_status( { message_id => $message->{'message_id'},
1470                                status     => 'failed' } );
1471         return;
1472     }
1473
1474     my $success = C4::SMS->send_sms( { destination => $patron->smsalertnumber,
1475                                        message     => $message->{'content'},
1476                                      } );
1477     _set_message_status( { message_id => $message->{'message_id'},
1478                            status     => ($success ? 'sent' : 'failed') } );
1479     return $success;
1480 }
1481
1482 sub _update_message_to_address {
1483     my ($id, $to)= @_;
1484     my $dbh = C4::Context->dbh();
1485     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1486 }
1487
1488 sub _set_message_status {
1489     my $params = shift or return;
1490
1491     foreach my $required_parameter ( qw( message_id status ) ) {
1492         return unless exists $params->{ $required_parameter };
1493     }
1494
1495     my $dbh = C4::Context->dbh();
1496     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1497     my $sth = $dbh->prepare( $statement );
1498     my $result = $sth->execute( $params->{'status'},
1499                                 $params->{'message_id'} );
1500     return $result;
1501 }
1502
1503 sub _process_tt {
1504     my ( $params ) = @_;
1505
1506     my $content = $params->{content};
1507     my $tables = $params->{tables};
1508     my $loops = $params->{loops};
1509     my $substitute = $params->{substitute} || {};
1510
1511     my $use_template_cache = C4::Context->config('template_cache_dir') && defined $ENV{GATEWAY_INTERFACE};
1512     my $template           = Template->new(
1513         {
1514             EVAL_PERL    => 1,
1515             ABSOLUTE     => 1,
1516             PLUGIN_BASE  => 'Koha::Template::Plugin',
1517             COMPILE_EXT  => $use_template_cache ? '.ttc' : '',
1518             COMPILE_DIR  => $use_template_cache ? C4::Context->config('template_cache_dir') : '',
1519             FILTERS      => {},
1520             ENCODING     => 'UTF-8',
1521         }
1522     ) or die Template->error();
1523
1524     my $tt_params = { %{ _get_tt_params( $tables ) }, %{ _get_tt_params( $loops, 'is_a_loop' ) }, %$substitute };
1525
1526     $content = add_tt_filters( $content );
1527     $content = qq|[% USE KohaDates %][% USE Remove_MARC_punctuation %]$content|;
1528
1529     my $output;
1530     $template->process( \$content, $tt_params, \$output ) || croak "ERROR PROCESSING TEMPLATE: " . $template->error();
1531
1532     return $output;
1533 }
1534
1535 sub _get_tt_params {
1536     my ($tables, $is_a_loop) = @_;
1537
1538     my $params;
1539     $is_a_loop ||= 0;
1540
1541     my $config = {
1542         article_requests => {
1543             module   => 'Koha::ArticleRequests',
1544             singular => 'article_request',
1545             plural   => 'article_requests',
1546             pk       => 'id',
1547           },
1548         biblio => {
1549             module   => 'Koha::Biblios',
1550             singular => 'biblio',
1551             plural   => 'biblios',
1552             pk       => 'biblionumber',
1553         },
1554         biblioitems => {
1555             module   => 'Koha::Biblioitems',
1556             singular => 'biblioitem',
1557             plural   => 'biblioitems',
1558             pk       => 'biblioitemnumber',
1559         },
1560         borrowers => {
1561             module   => 'Koha::Patrons',
1562             singular => 'borrower',
1563             plural   => 'borrowers',
1564             pk       => 'borrowernumber',
1565         },
1566         branches => {
1567             module   => 'Koha::Libraries',
1568             singular => 'branch',
1569             plural   => 'branches',
1570             pk       => 'branchcode',
1571         },
1572         items => {
1573             module   => 'Koha::Items',
1574             singular => 'item',
1575             plural   => 'items',
1576             pk       => 'itemnumber',
1577         },
1578         opac_news => {
1579             module   => 'Koha::News',
1580             singular => 'news',
1581             plural   => 'news',
1582             pk       => 'idnew',
1583         },
1584         aqorders => {
1585             module   => 'Koha::Acquisition::Orders',
1586             singular => 'order',
1587             plural   => 'orders',
1588             pk       => 'ordernumber',
1589         },
1590         reserves => {
1591             module   => 'Koha::Holds',
1592             singular => 'hold',
1593             plural   => 'holds',
1594             fk       => [ 'borrowernumber', 'biblionumber' ],
1595         },
1596         serial => {
1597             module   => 'Koha::Serials',
1598             singular => 'serial',
1599             plural   => 'serials',
1600             pk       => 'serialid',
1601         },
1602         subscription => {
1603             module   => 'Koha::Subscriptions',
1604             singular => 'subscription',
1605             plural   => 'subscriptions',
1606             pk       => 'subscriptionid',
1607         },
1608         suggestions => {
1609             module   => 'Koha::Suggestions',
1610             singular => 'suggestion',
1611             plural   => 'suggestions',
1612             pk       => 'suggestionid',
1613         },
1614         issues => {
1615             module   => 'Koha::Checkouts',
1616             singular => 'checkout',
1617             plural   => 'checkouts',
1618             fk       => 'itemnumber',
1619         },
1620         old_issues => {
1621             module   => 'Koha::Old::Checkouts',
1622             singular => 'old_checkout',
1623             plural   => 'old_checkouts',
1624             fk       => 'itemnumber',
1625         },
1626         overdues => {
1627             module   => 'Koha::Checkouts',
1628             singular => 'overdue',
1629             plural   => 'overdues',
1630             fk       => 'itemnumber',
1631         },
1632         borrower_modifications => {
1633             module   => 'Koha::Patron::Modifications',
1634             singular => 'patron_modification',
1635             plural   => 'patron_modifications',
1636             fk       => 'verification_token',
1637         },
1638     };
1639
1640     foreach my $table ( keys %$tables ) {
1641         next unless $config->{$table};
1642
1643         my $ref = ref( $tables->{$table} ) || q{};
1644         my $module = $config->{$table}->{module};
1645
1646         if ( can_load( modules => { $module => undef } ) ) {
1647             my $pk = $config->{$table}->{pk};
1648             my $fk = $config->{$table}->{fk};
1649
1650             if ( $is_a_loop ) {
1651                 my $values = $tables->{$table} || [];
1652                 unless ( ref( $values ) eq 'ARRAY' ) {
1653                     croak "ERROR processing table $table. Wrong API call.";
1654                 }
1655                 my $key = $pk ? $pk : $fk;
1656                 # $key does not come from user input
1657                 my $objects = $module->search(
1658                     { $key => $values },
1659                     {
1660                             # We want to retrieve the data in the same order
1661                             # FIXME MySQLism
1662                             # field is a MySQLism, but they are no other way to do it
1663                             # To be generic we could do it in perl, but we will need to fetch
1664                             # all the data then order them
1665                         @$values ? ( order_by => \[ "field($key, " . join( ', ', @$values ) . ")" ] ) : ()
1666                     }
1667                 );
1668                 $params->{ $config->{$table}->{plural} } = $objects;
1669             }
1670             elsif ( $ref eq q{} || $ref eq 'HASH' ) {
1671                 my $id = ref $ref eq 'HASH' ? $tables->{$table}->{$pk} : $tables->{$table};
1672                 my $object;
1673                 if ( $fk ) { # Using a foreign key for lookup
1674                     if ( ref( $fk ) eq 'ARRAY' ) { # Foreign key is multi-column
1675                         my $search;
1676                         foreach my $key ( @$fk ) {
1677                             $search->{$key} = $id->{$key};
1678                         }
1679                         $object = $module->search( $search )->last();
1680                     } else { # Foreign key is single column
1681                         $object = $module->search( { $fk => $id } )->last();
1682                     }
1683                 } else { # using the table's primary key for lookup
1684                     $object = $module->find($id);
1685                 }
1686                 $params->{ $config->{$table}->{singular} } = $object;
1687             }
1688             else {    # $ref eq 'ARRAY'
1689                 my $object;
1690                 if ( @{ $tables->{$table} } == 1 ) {    # Param is a single key
1691                     $object = $module->search( { $pk => $tables->{$table} } )->last();
1692                 }
1693                 else {                                  # Params are mutliple foreign keys
1694                     croak "Multiple foreign keys (table $table) should be passed using an hashref";
1695                 }
1696                 $params->{ $config->{$table}->{singular} } = $object;
1697             }
1698         }
1699         else {
1700             croak "ERROR LOADING MODULE $module: $Module::Load::Conditional::ERROR";
1701         }
1702     }
1703
1704     $params->{today} = output_pref({ dt => dt_from_string, dateformat => 'iso' });
1705
1706     return $params;
1707 }
1708
1709 =head3 add_tt_filters
1710
1711 $content = add_tt_filters( $content );
1712
1713 Add TT filters to some specific fields if needed.
1714
1715 For now we only add the Remove_MARC_punctuation TT filter to biblio and biblioitem fields
1716
1717 =cut
1718
1719 sub add_tt_filters {
1720     my ( $content ) = @_;
1721     $content =~ s|\[%\s*biblio\.(.*?)\s*%\]|[% biblio.$1 \| \$Remove_MARC_punctuation %]|gxms;
1722     $content =~ s|\[%\s*biblioitem\.(.*?)\s*%\]|[% biblioitem.$1 \| \$Remove_MARC_punctuation %]|gxms;
1723     return $content;
1724 }
1725
1726 =head2 get_item_content
1727
1728     my $item = Koha::Items->find(...)->unblessed;
1729     my @item_content_fields = qw( date_due title barcode author itemnumber );
1730     my $item_content = C4::Letters::get_item_content({
1731                              item => $item,
1732                              item_content_fields => \@item_content_fields
1733                        });
1734
1735 This function generates a tab-separated list of values for the passed item. Dates
1736 are formatted following the current setup.
1737
1738 =cut
1739
1740 sub get_item_content {
1741     my ( $params ) = @_;
1742     my $item = $params->{item};
1743     my $dateonly = $params->{dateonly} || 0;
1744     my $item_content_fields = $params->{item_content_fields} || [];
1745
1746     return unless $item;
1747
1748     my @item_info = map {
1749         $_ =~ /^date|date$/
1750           ? eval {
1751             output_pref(
1752                 { dt => dt_from_string( $item->{$_} ), dateonly => $dateonly } );
1753           }
1754           : $item->{$_}
1755           || ''
1756     } @$item_content_fields;
1757     return join( "\t", @item_info ) . "\n";
1758 }
1759
1760 1;
1761 __END__