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