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