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