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