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