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