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