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