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