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 MIME::Lite;
  23 use Date::Calc qw( Add_Delta_Days );
  24 use Encode;
  25 use Carp;
  26 use Template;
  27 use Module::Load::Conditional qw(can_load);
  28
  29 use Try::Tiny;
  30
  31 use C4::Members;
  32 use C4::Log;
  33 use C4::SMS;
  34 use C4::Templates;
  35 use C4::Debug;
  36 use Koha::DateUtils;
  37 use Koha::SMS::Providers;
  38
  39 use Koha::Email;
  40 use Koha::Notice::Messages;
  41 use Koha::Notice::Templates;
  42 use Koha::DateUtils qw( format_sqldatetime dt_from_string );
  43 use Koha::Patrons;
  44 use Koha::SMTP::Servers;
  45 use Koha::Subscriptions;
  46
  47 use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  48
  49 BEGIN {
  50     require Exporter;
  51     @ISA = qw(Exporter);
  52     @EXPORT = qw(
  53         &EnqueueLetter &GetLetters &GetLettersAvailableForALibrary &GetLetterTemplates &DelLetter &GetPreparedLetter &GetWrappedLetter &SendAlerts &GetPrintMessages &GetMessageTransportTypes
  54     );
  55 }
  56
  57 =head1 NAME
  58
  59 C4::Letters - Give functions for Letters management
  60
  61 =head1 SYNOPSIS
  62
  63   use C4::Letters;
  64
  65 =head1 DESCRIPTION
  66
  67   "Letters" is the tool used in Koha to manage informations sent to the patrons and/or the library. This include some cron jobs like
  68   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)
  69
  70   Letters are managed through "alerts" sent by Koha on some events. All "alert" related functions are in this module too.
  71
  72 =head2 GetLetters([$module])
  73
  74   $letters = &GetLetters($module);
  75   returns informations about letters.
  76   if needed, $module filters for letters given module
  77
  78   DEPRECATED - You must use Koha::Notice::Templates instead
  79   The group by clause is confusing and can lead to issues
  80
  81 =cut
  82
  83 sub GetLetters {
  84     my ($filters) = @_;
  85     my $module    = $filters->{module};
  86     my $code      = $filters->{code};
  87     my $branchcode = $filters->{branchcode};
  88     my $dbh       = C4::Context->dbh;
  89     my $letters   = $dbh->selectall_arrayref(
  90         q|
  91             SELECT code, module, name
  92             FROM letter
  93             WHERE 1
  94         |
  95           . ( $module ? q| AND module = ?| : q|| )
  96           . ( $code   ? q| AND code = ?|   : q|| )
  97           . ( defined $branchcode   ? q| AND branchcode = ?|   : q|| )
  98           . q| GROUP BY code, module, name ORDER BY name|, { Slice => {} }
  99         , ( $module ? $module : () )
 100         , ( $code ? $code : () )
 101         , ( defined $branchcode ? $branchcode : () )
 102     );
 103
 104     return $letters;
 105 }
 106
 107 =head2 GetLetterTemplates
 108
 109     my $letter_templates = GetLetterTemplates(
 110         {
 111             module => 'circulation',
 112             code => 'my code',
 113             branchcode => 'CPL', # '' for default,
 114         }
 115     );
 116
 117     Return a hashref of letter templates.
 118
 119 =cut
 120
 121 sub GetLetterTemplates {
 122     my ( $params ) = @_;
 123
 124     my $module    = $params->{module};
 125     my $code      = $params->{code};
 126     my $branchcode = $params->{branchcode} // '';
 127     my $dbh       = C4::Context->dbh;
 128     return Koha::Notice::Templates->search(
 129         {
 130             module     => $module,
 131             code       => $code,
 132             branchcode => $branchcode,
 133             (
 134                 C4::Context->preference('TranslateNotices')
 135                 ? ()
 136                 : ( lang => 'default' )
 137             )
 138         }
 139     )->unblessed;
 140 }
 141
 142 =head2 GetLettersAvailableForALibrary
 143
 144     my $letters = GetLettersAvailableForALibrary(
 145         {
 146             branchcode => 'CPL', # '' for default
 147             module => 'circulation',
 148         }
 149     );
 150
 151     Return an arrayref of letters, sorted by name.
 152     If a specific letter exist for the given branchcode, it will be retrieve.
 153     Otherwise the default letter will be.
 154
 155 =cut
 156
 157 sub GetLettersAvailableForALibrary {
 158     my ($filters)  = @_;
 159     my $branchcode = $filters->{branchcode};
 160     my $module     = $filters->{module};
 161
 162     croak "module should be provided" unless $module;
 163
 164     my $dbh             = C4::Context->dbh;
 165     my $default_letters = $dbh->selectall_arrayref(
 166         q|
 167             SELECT module, code, branchcode, name
 168             FROM letter
 169             WHERE 1
 170         |
 171           . q| AND branchcode = ''|
 172           . ( $module ? q| AND module = ?| : q|| )
 173           . q| ORDER BY name|, { Slice => {} }
 174         , ( $module ? $module : () )
 175     );
 176
 177     my $specific_letters;
 178     if ($branchcode) {
 179         $specific_letters = $dbh->selectall_arrayref(
 180             q|
 181                 SELECT module, code, branchcode, name
 182                 FROM letter
 183                 WHERE 1
 184             |
 185               . q| AND branchcode = ?|
 186               . ( $module ? q| AND module = ?| : q|| )
 187               . q| ORDER BY name|, { Slice => {} }
 188             , $branchcode
 189             , ( $module ? $module : () )
 190         );
 191     }
 192
 193     my %letters;
 194     for my $l (@$default_letters) {
 195         $letters{ $l->{code} } = $l;
 196     }
 197     for my $l (@$specific_letters) {
 198         # Overwrite the default letter with the specific one.
 199         $letters{ $l->{code} } = $l;
 200     }
 201
 202     return [ map { $letters{$_} }
 203           sort { $letters{$a}->{name} cmp $letters{$b}->{name} }
 204           keys %letters ];
 205
 206 }
 207
 208 sub getletter {
 209     my ( $module, $code, $branchcode, $message_transport_type, $lang) = @_;
 210     $message_transport_type //= '%';
 211     $lang = 'default' unless( $lang && C4::Context->preference('TranslateNotices') );
 212
 213
 214     my $only_my_library = C4::Context->only_my_library;
 215     if ( $only_my_library and $branchcode ) {
 216         $branchcode = C4::Context::mybranch();
 217     }
 218     $branchcode //= '';
 219
 220     my $dbh = C4::Context->dbh;
 221     my $sth = $dbh->prepare(q{
 222         SELECT *
 223         FROM letter
 224         WHERE module=? AND code=? AND (branchcode = ? OR branchcode = '')
 225         AND message_transport_type LIKE ?
 226         AND lang =?
 227         ORDER BY branchcode DESC LIMIT 1
 228     });
 229     $sth->execute( $module, $code, $branchcode, $message_transport_type, $lang );
 230     my $line = $sth->fetchrow_hashref
 231       or return;
 232     $line->{'content-type'} = 'text/html; charset="UTF-8"' if $line->{is_html};
 233     return { %$line };
 234 }
 235
 236
 237 =head2 DelLetter
 238
 239     DelLetter(
 240         {
 241             branchcode => 'CPL',
 242             module => 'circulation',
 243             code => 'my code',
 244             [ mtt => 'email', ]
 245         }
 246     );
 247
 248     Delete the letter. The mtt parameter is facultative.
 249     If not given, all templates mathing the other parameters will be removed.
 250
 251 =cut
 252
 253 sub DelLetter {
 254     my ($params)   = @_;
 255     my $branchcode = $params->{branchcode};
 256     my $module     = $params->{module};
 257     my $code       = $params->{code};
 258     my $mtt        = $params->{mtt};
 259     my $lang       = $params->{lang};
 260     my $dbh        = C4::Context->dbh;
 261     $dbh->do(q|
 262         DELETE FROM letter
 263         WHERE branchcode = ?
 264           AND module = ?
 265           AND code = ?
 266     |
 267     . ( $mtt ? q| AND message_transport_type = ?| : q|| )
 268     . ( $lang? q| AND lang = ?| : q|| )
 269     , undef, $branchcode, $module, $code, ( $mtt ? $mtt : () ), ( $lang ? $lang : () ) );
 270 }
 271
 272 =head2 SendAlerts
 273
 274     my $err = &SendAlerts($type, $externalid, $letter_code);
 275
 276     Parameters:
 277       - $type : the type of alert
 278       - $externalid : the id of the "object" to query
 279       - $letter_code : the notice template to use
 280
 281     C<&SendAlerts> sends an email notice directly to a patron or a vendor.
 282
 283     Currently it supports ($type):
 284       - claim serial issues (claimissues)
 285       - claim acquisition orders (claimacquisition)
 286       - send acquisition orders to the vendor (orderacquisition)
 287       - notify patrons about newly received serial issues (issue)
 288       - notify patrons when their account is created (members)
 289
 290     Returns undef or { error => 'message } on failure.
 291     Returns true on success.
 292
 293 =cut
 294
 295 sub SendAlerts {
 296     my ( $type, $externalid, $letter_code ) = @_;
 297     my $dbh = C4::Context->dbh;
 298     my $error;
 299
 300     if ( $type eq 'issue' ) {
 301
 302         # prepare the letter...
 303         # search the subscriptionid
 304         my $sth =
 305           $dbh->prepare(
 306             "SELECT subscriptionid FROM serial WHERE serialid=?");
 307         $sth->execute($externalid);
 308         my ($subscriptionid) = $sth->fetchrow
 309           or warn( "No subscription for '$externalid'" ),
 310              return;
 311
 312         # search the biblionumber
 313         $sth =
 314           $dbh->prepare(
 315             "SELECT biblionumber FROM subscription WHERE subscriptionid=?");
 316         $sth->execute($subscriptionid);
 317         my ($biblionumber) = $sth->fetchrow
 318           or warn( "No biblionumber for '$subscriptionid'" ),
 319              return;
 320
 321         # find the list of subscribers to notify
 322         my $subscription = Koha::Subscriptions->find( $subscriptionid );
 323         my $subscribers = $subscription->subscribers;
 324         while ( my $patron = $subscribers->next ) {
 325             my $email = $patron->email or next;
 326
 327 #                    warn "sending issues...";
 328             my $userenv = C4::Context->userenv;
 329             my $library = $patron->library;
 330             my $letter = GetPreparedLetter (
 331                 module => 'serial',
 332                 letter_code => $letter_code,
 333                 branchcode => $userenv->{branch},
 334                 tables => {
 335                     'branches'    => $library->branchcode,
 336                     'biblio'      => $biblionumber,
 337                     'biblioitems' => $biblionumber,
 338                     'borrowers'   => $patron->unblessed,
 339                     'subscription' => $subscriptionid,
 340                     'serial' => $externalid,
 341                 },
 342                 want_librarian => 1,
 343             ) or return;
 344
 345             # FIXME: This 'default' behaviour should be moved to Koha::Email
 346             my $mail = Koha::Email->create(
 347                 {
 348                     to       => $email,
 349                     from     => $library->branchemail,
 350                     reply_to => $library->branchreplyto,
 351                     sender   => $library->branchreturnpath,
 352                     subject  => "" . $letter->{title},
 353                 }
 354             );
 355
 356             if ( $letter->{is_html} ) {
 357                 $mail->html_body( _wrap_html( $letter->{content}, "" . $letter->{title} ) );
 358             }
 359             else {
 360                 $mail->text_body( $letter->{content} );
 361             }
 362
 363             my $success = try {
 364                 $mail->send_or_die({ transport => $library->smtp_server->transport });
 365             }
 366             catch {
 367                 # We expect ref($_) eq 'Email::Sender::Failure'
 368                 $error = $_->message;
 369
 370                 carp "$_";
 371                 return;
 372             };
 373
 374             return { error => $error }
 375                 unless $success;
 376         }
 377     }
 378     elsif ( $type eq 'claimacquisition' or $type eq 'claimissues' or $type eq 'orderacquisition' ) {
 379
 380         # prepare the letter...
 381         my $strsth;
 382         my $sthorders;
 383         my $dataorders;
 384         my $action;
 385         my $basketno;
 386         if ( $type eq 'claimacquisition') {
 387             $strsth = qq{
 388             SELECT aqorders.*,aqbasket.*,biblio.*,biblioitems.*
 389             FROM aqorders
 390             LEFT JOIN aqbasket ON aqbasket.basketno=aqorders.basketno
 391             LEFT JOIN biblio ON aqorders.biblionumber=biblio.biblionumber
 392             LEFT JOIN biblioitems ON aqorders.biblionumber=biblioitems.biblionumber
 393             WHERE aqorders.ordernumber IN (
 394             };
 395
 396             if (!@$externalid){
 397                 carp "No order selected";
 398                 return { error => "no_order_selected" };
 399             }
 400             $strsth .= join( ",", ('?') x @$externalid ) . ")";
 401             $action = "ACQUISITION CLAIM";
 402             $sthorders = $dbh->prepare($strsth);
 403             $sthorders->execute( @$externalid );
 404             $dataorders = $sthorders->fetchall_arrayref( {} );
 405         }
 406
 407         if ($type eq 'claimissues') {
 408             $strsth = qq{
 409             SELECT serial.*,subscription.*, biblio.*, biblioitems.*, aqbooksellers.*,
 410             aqbooksellers.id AS booksellerid
 411             FROM serial
 412             LEFT JOIN subscription ON serial.subscriptionid=subscription.subscriptionid
 413             LEFT JOIN biblio ON serial.biblionumber=biblio.biblionumber
 414             LEFT JOIN biblioitems ON serial.biblionumber = biblioitems.biblionumber
 415             LEFT JOIN aqbooksellers ON subscription.aqbooksellerid=aqbooksellers.id
 416             WHERE serial.serialid IN (
 417             };
 418
 419             if (!@$externalid){
 420                 carp "No issues selected";
 421                 return { error => "no_issues_selected" };
 422             }
 423
 424             $strsth .= join( ",", ('?') x @$externalid ) . ")";
 425             $action = "SERIAL CLAIM";
 426             $sthorders = $dbh->prepare($strsth);
 427             $sthorders->execute( @$externalid );
 428             $dataorders = $sthorders->fetchall_arrayref( {} );
 429         }
 430
 431         if ( $type eq 'orderacquisition') {
 432             my $basketno = $externalid;
 433             $strsth = qq{
 434             SELECT aqorders.*,aqbasket.*,biblio.*,biblioitems.*
 435             FROM aqorders
 436             LEFT JOIN aqbasket ON aqbasket.basketno=aqorders.basketno
 437             LEFT JOIN biblio ON aqorders.biblionumber=biblio.biblionumber
 438             LEFT JOIN biblioitems ON aqorders.biblionumber=biblioitems.biblionumber
 439             WHERE aqbasket.basketno = ?
 440             AND orderstatus IN ('new','ordered')
 441             };
 442
 443             unless ( $basketno ) {
 444                 carp "No basketnumber given";
 445                 return { error => "no_basketno" };
 446             }
 447             $action = "ACQUISITION ORDER";
 448             $sthorders = $dbh->prepare($strsth);
 449             $sthorders->execute($basketno);
 450             $dataorders = $sthorders->fetchall_arrayref( {} );
 451         }
 452
 453         my $sthbookseller =
 454           $dbh->prepare("select * from aqbooksellers where id=?");
 455         $sthbookseller->execute( $dataorders->[0]->{booksellerid} );
 456         my $databookseller = $sthbookseller->fetchrow_hashref;
 457
 458         my $addressee =  $type eq 'claimacquisition' || $type eq 'orderacquisition' ? 'acqprimary' : 'serialsprimary';
 459
 460         my $sthcontact =
 461           $dbh->prepare("SELECT * FROM aqcontacts WHERE booksellerid=? AND $type=1 ORDER BY $addressee DESC");
 462         $sthcontact->execute( $dataorders->[0]->{booksellerid} );
 463         my $datacontact = $sthcontact->fetchrow_hashref;
 464
 465         my @email;
 466         my @cc;
 467         push @email, $datacontact->{email}           if ( $datacontact && $datacontact->{email} );
 468         unless (@email) {
 469             warn "Bookseller $dataorders->[0]->{booksellerid} without emails";
 470             return { error => "no_email" };
 471         }
 472         my $addlcontact;
 473         while ($addlcontact = $sthcontact->fetchrow_hashref) {
 474             push @cc, $addlcontact->{email} if ( $addlcontact && $addlcontact->{email} );
 475         }
 476
 477         my $userenv = C4::Context->userenv;
 478         my $letter = GetPreparedLetter (
 479             module => $type,
 480             letter_code => $letter_code,
 481             branchcode => $userenv->{branch},
 482             tables => {
 483                 'branches'      => $userenv->{branch},
 484                 'aqbooksellers' => $databookseller,
 485                 'aqcontacts'    => $datacontact,
 486                 'aqbasket'      => $basketno,
 487             },
 488             repeat => $dataorders,
 489             want_librarian => 1,
 490         ) or return { error => "no_letter" };
 491
 492         # Remove the order tag
 493         $letter->{content} =~ s/<order>(.*?)<\/order>/$1/gxms;
 494
 495         # ... then send mail
 496         my $library = Koha::Libraries->find( $userenv->{branch} );
 497         my $mail = Koha::Email->create(
 498             {
 499                 to => join( ',', @email ),
 500                 cc => join( ',', @cc ),
 501                 (
 502                     (
 503                         C4::Context->preference("ClaimsBccCopy")
 504                           && ( $type eq 'claimacquisition'
 505                             || $type eq 'claimissues' )
 506                     )
 507                     ? ( bcc => $userenv->{emailaddress} )
 508                     : ()
 509                 ),
 510                 from => $library->branchemail
 511                   || C4::Context->preference('KohaAdminEmailAddress'),
 512                 subject => "" . $letter->{title},
 513             }
 514         );
 515
 516         if ( $letter->{is_html} ) {
 517             $mail->html_body( _wrap_html( $letter->{content}, "" . $letter->{title} ) );
 518         }
 519         else {
 520             $mail->text_body( "" . $letter->{content} );
 521         }
 522
 523         my $success = try {
 524             $mail->send_or_die({ transport => $library->smtp_server->transport });
 525         }
 526         catch {
 527             # We expect ref($_) eq 'Email::Sender::Failure'
 528             $error = $_->message;
 529
 530             carp "$_";
 531             return;
 532         };
 533
 534         return { error => $error }
 535             unless $success;
 536
 537         logaction(
 538             "ACQUISITION",
 539             $action,
 540             undef,
 541             "To="
 542                 . join( ',', @email )
 543                 . " Title="
 544                 . $letter->{title}
 545                 . " Content="
 546                 . $letter->{content}
 547         ) if C4::Context->preference("LetterLog");
 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     itemnumber = ? ORDER BY timestamp DESC LIMIT 1"  :
 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 =cut
 938
 939 sub EnqueueLetter {
 940     my $params = shift or return;
 941
 942     return unless exists $params->{'letter'};
 943 #   return unless exists $params->{'borrowernumber'};
 944     return unless exists $params->{'message_transport_type'};
 945
 946     my $content = $params->{letter}->{content};
 947     $content =~ s/\s+//g if(defined $content);
 948     if ( not defined $content or $content eq '' ) {
 949         warn "Trying to add an empty message to the message queue" if $debug;
 950         return;
 951     }
 952
 953     # If we have any attachments we should encode then into the body.
 954     if ( $params->{'attachments'} ) {
 955         $params->{'letter'} = _add_attachments(
 956             {   letter      => $params->{'letter'},
 957                 attachments => $params->{'attachments'},
 958                 message     => MIME::Lite->new( Type => 'multipart/mixed' ),
 959             }
 960         );
 961     }
 962
 963     my $dbh       = C4::Context->dbh();
 964     my $statement = << 'ENDSQL';
 965 INSERT INTO message_queue
 966 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, reply_address, content_type, delivery_note )
 967 VALUES
 968 ( ?,              ?,       ?,       ?,        ?,           ?,                      ?,      CAST(NOW() AS DATE),       ?,          ?,            ?,           ?,              ? )
 969 ENDSQL
 970
 971     my $sth    = $dbh->prepare($statement);
 972     my $result = $sth->execute(
 973         $params->{'borrowernumber'},              # borrowernumber
 974         $params->{'letter'}->{'title'},           # subject
 975         $params->{'letter'}->{'content'},         # content
 976         $params->{'letter'}->{'metadata'} || '',  # metadata
 977         $params->{'letter'}->{'code'}     || '',  # letter_code
 978         $params->{'message_transport_type'},      # message_transport_type
 979         'pending',                                # status
 980         $params->{'to_address'},                  # to_address
 981         $params->{'from_address'},                # from_address
 982         $params->{'reply_address'},               # reply_address
 983         $params->{'letter'}->{'content-type'},    # content_type
 984         $params->{'delivery_note'}        || '',  # delivery_note
 985     );
 986     return $dbh->last_insert_id(undef,undef,'message_queue', undef);
 987 }
 988
 989 =head2 SendQueuedMessages ([$hashref])
 990
 991     my $sent = SendQueuedMessages({
 992         letter_code => $letter_code,
 993         borrowernumber => $who_letter_is_for,
 994         limit => 50,
 995         verbose => 1,
 996         type => 'sms',
 997     });
 998
 999 Sends all of the 'pending' items in the message queue, unless
1000 parameters are passed.
1001
1002 The letter_code, borrowernumber and limit parameters are used
1003 to build a parameter set for _get_unsent_messages, thus limiting
1004 which pending messages will be processed. They are all optional.
1005
1006 The verbose parameter can be used to generate debugging output.
1007 It is also optional.
1008
1009 Returns number of messages sent.
1010
1011 =cut
1012
1013 sub SendQueuedMessages {
1014     my $params = shift;
1015
1016     my $which_unsent_messages  = {
1017         'message_id'     => $params->{'message_id'},
1018         'limit'          => $params->{'limit'} // 0,
1019         'borrowernumber' => $params->{'borrowernumber'} // q{},
1020         'letter_code'    => $params->{'letter_code'} // q{},
1021         'type'           => $params->{'type'} // q{},
1022     };
1023     my $unsent_messages = _get_unsent_messages( $which_unsent_messages );
1024     MESSAGE: foreach my $message ( @$unsent_messages ) {
1025         my $message_object = Koha::Notice::Messages->find( $message->{message_id} );
1026         # If this fails the database is unwritable and we won't manage to send a message that continues to be marked 'pending'
1027         $message_object->make_column_dirty('status');
1028         return unless $message_object->store;
1029
1030         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
1031         warn sprintf( 'sending %s message to patron: %s',
1032                       $message->{'message_transport_type'},
1033                       $message->{'borrowernumber'} || 'Admin' )
1034           if $params->{'verbose'} or $debug;
1035         # This is just begging for subclassing
1036         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
1037         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
1038             _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
1039         }
1040         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
1041             if ( C4::Context->preference('SMSSendDriver') eq 'Email' ) {
1042                 my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1043                 my $sms_provider = Koha::SMS::Providers->find( $patron->sms_provider_id );
1044                 unless ( $sms_provider ) {
1045                     warn sprintf( "Patron %s has no sms provider id set!", $message->{'borrowernumber'} ) if $params->{'verbose'} or $debug;
1046                     _set_message_status( { message_id => $message->{'message_id'}, status => 'failed' } );
1047                     next MESSAGE;
1048                 }
1049                 unless ( $patron->smsalertnumber ) {
1050                     _set_message_status( { message_id => $message->{'message_id'}, status => 'failed' } );
1051                     warn sprintf( "No smsalertnumber found for patron %s!", $message->{'borrowernumber'} ) if $params->{'verbose'} or $debug;
1052                     next MESSAGE;
1053                 }
1054                 $message->{to_address}  = $patron->smsalertnumber; #Sometime this is set to email - sms should always use smsalertnumber
1055                 $message->{to_address} .= '@' . $sms_provider->domain();
1056
1057                 # Check for possible from_address override
1058                 my $from_address = C4::Context->preference('EmailSMSSendDriverFromAddress');
1059                 if ($from_address && $message->{from_address} ne $from_address) {
1060                     $message->{from_address} = $from_address;
1061                     _update_message_from_address($message->{'message_id'}, $message->{from_address});
1062                 }
1063
1064                 _update_message_to_address($message->{'message_id'}, $message->{to_address});
1065                 _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
1066             } else {
1067                 _send_message_by_sms( $message );
1068             }
1069         }
1070     }
1071     return scalar( @$unsent_messages );
1072 }
1073
1074 =head2 GetRSSMessages
1075
1076   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
1077
1078 returns a listref of all queued RSS messages for a particular person.
1079
1080 =cut
1081
1082 sub GetRSSMessages {
1083     my $params = shift;
1084
1085     return unless $params;
1086     return unless ref $params;
1087     return unless $params->{'borrowernumber'};
1088
1089     return _get_unsent_messages( { message_transport_type => 'rss',
1090                                    limit                  => $params->{'limit'},
1091                                    borrowernumber         => $params->{'borrowernumber'}, } );
1092 }
1093
1094 =head2 GetPrintMessages
1095
1096   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
1097
1098 Returns a arrayref of all queued print messages (optionally, for a particular
1099 person).
1100
1101 =cut
1102
1103 sub GetPrintMessages {
1104     my $params = shift || {};
1105
1106     return _get_unsent_messages( { message_transport_type => 'print',
1107                                    borrowernumber         => $params->{'borrowernumber'},
1108                                  } );
1109 }
1110
1111 =head2 GetQueuedMessages ([$hashref])
1112
1113   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
1114
1115 Fetches a list of messages from the message queue optionally filtered by borrowernumber
1116 and limited to specified limit.
1117
1118 Return is an arrayref of hashes, each has represents a message in the message queue.
1119
1120 =cut
1121
1122 sub GetQueuedMessages {
1123     my $params = shift;
1124
1125     my $dbh = C4::Context->dbh();
1126     my $statement = << 'ENDSQL';
1127 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued, updated_on, delivery_note
1128 FROM message_queue
1129 ENDSQL
1130
1131     my @query_params;
1132     my @whereclauses;
1133     if ( exists $params->{'borrowernumber'} ) {
1134         push @whereclauses, ' borrowernumber = ? ';
1135         push @query_params, $params->{'borrowernumber'};
1136     }
1137
1138     if ( @whereclauses ) {
1139         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
1140     }
1141
1142     if ( defined $params->{'limit'} ) {
1143         $statement .= ' LIMIT ? ';
1144         push @query_params, $params->{'limit'};
1145     }
1146
1147     my $sth = $dbh->prepare( $statement );
1148     my $result = $sth->execute( @query_params );
1149     return $sth->fetchall_arrayref({});
1150 }
1151
1152 =head2 GetMessageTransportTypes
1153
1154   my @mtt = GetMessageTransportTypes();
1155
1156   returns an arrayref of transport types
1157
1158 =cut
1159
1160 sub GetMessageTransportTypes {
1161     my $dbh = C4::Context->dbh();
1162     my $mtts = $dbh->selectcol_arrayref("
1163         SELECT message_transport_type
1164         FROM message_transport_types
1165         ORDER BY message_transport_type
1166     ");
1167     return $mtts;
1168 }
1169
1170 =head2 GetMessage
1171
1172     my $message = C4::Letters::Message($message_id);
1173
1174 =cut
1175
1176 sub GetMessage {
1177     my ( $message_id ) = @_;
1178     return unless $message_id;
1179     my $dbh = C4::Context->dbh;
1180     return $dbh->selectrow_hashref(q|
1181         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, delivery_note
1182         FROM message_queue
1183         WHERE message_id = ?
1184     |, {}, $message_id );
1185 }
1186
1187 =head2 ResendMessage
1188
1189   Attempt to resend a message which has failed previously.
1190
1191   my $has_been_resent = C4::Letters::ResendMessage($message_id);
1192
1193   Updates the message to 'pending' status so that
1194   it will be resent later on.
1195
1196   returns 1 on success, 0 on failure, undef if no message was found
1197
1198 =cut
1199
1200 sub ResendMessage {
1201     my $message_id = shift;
1202     return unless $message_id;
1203
1204     my $message = GetMessage( $message_id );
1205     return unless $message;
1206     my $rv = 0;
1207     if ( $message->{status} ne 'pending' ) {
1208         $rv = C4::Letters::_set_message_status({
1209             message_id => $message_id,
1210             status => 'pending',
1211         });
1212         $rv = $rv > 0? 1: 0;
1213         # Clear destination email address to force address update
1214         _update_message_to_address( $message_id, undef ) if $rv &&
1215             $message->{message_transport_type} eq 'email';
1216     }
1217     return $rv;
1218 }
1219
1220 =head2 _add_attachements
1221
1222   named parameters:
1223   letter - the standard letter hashref
1224   attachments - listref of attachments. each attachment is a hashref of:
1225     type - the mime type, like 'text/plain'
1226     content - the actual attachment
1227     filename - the name of the attachment.
1228   message - a MIME::Lite object to attach these to.
1229
1230   returns your letter object, with the content updated.
1231
1232 =cut
1233
1234 sub _add_attachments {
1235     my $params = shift;
1236
1237     my $letter = $params->{'letter'};
1238     my $attachments = $params->{'attachments'};
1239     return $letter unless @$attachments;
1240     my $message = $params->{'message'};
1241
1242     # First, we have to put the body in as the first attachment
1243     $message->attach(
1244         Type => $letter->{'content-type'} || 'TEXT',
1245         Data => $letter->{'is_html'}
1246             ? _wrap_html($letter->{'content'}, $letter->{'title'})
1247             : $letter->{'content'},
1248     );
1249
1250     foreach my $attachment ( @$attachments ) {
1251         $message->attach(
1252             Type     => $attachment->{'type'},
1253             Data     => $attachment->{'content'},
1254             Filename => $attachment->{'filename'},
1255         );
1256     }
1257     # we're forcing list context here to get the header, not the count back from grep.
1258     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
1259     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
1260     $letter->{'content'} = $message->body_as_string;
1261
1262     return $letter;
1263
1264 }
1265
1266 =head2 _get_unsent_messages
1267
1268   This function's parameter hash reference takes the following
1269   optional named parameters:
1270    message_transport_type: method of message sending (e.g. email, sms, etc.)
1271    borrowernumber        : who the message is to be sent
1272    letter_code           : type of message being sent (e.g. PASSWORD_RESET)
1273    message_id            : the message_id of the message. In that case the sub will return only 1 result
1274    limit                 : maximum number of messages to send
1275
1276   This function returns an array of matching hash referenced rows from
1277   message_queue with some borrower information added.
1278
1279 =cut
1280
1281 sub _get_unsent_messages {
1282     my $params = shift;
1283
1284     my $dbh = C4::Context->dbh();
1285     my $statement = qq{
1286         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.delivery_note
1287         FROM message_queue mq
1288         LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
1289         WHERE status = ?
1290     };
1291
1292     my @query_params = ('pending');
1293     if ( ref $params ) {
1294         if ( $params->{'message_transport_type'} ) {
1295             $statement .= ' AND mq.message_transport_type = ? ';
1296             push @query_params, $params->{'message_transport_type'};
1297         }
1298         if ( $params->{'borrowernumber'} ) {
1299             $statement .= ' AND mq.borrowernumber = ? ';
1300             push @query_params, $params->{'borrowernumber'};
1301         }
1302         if ( $params->{'letter_code'} ) {
1303             $statement .= ' AND mq.letter_code = ? ';
1304             push @query_params, $params->{'letter_code'};
1305         }
1306         if ( $params->{'type'} ) {
1307             $statement .= ' AND message_transport_type = ? ';
1308             push @query_params, $params->{'type'};
1309         }
1310         if ( $params->{message_id} ) {
1311             $statement .= ' AND message_id = ?';
1312             push @query_params, $params->{message_id};
1313         }
1314         if ( $params->{'limit'} ) {
1315             $statement .= ' limit ? ';
1316             push @query_params, $params->{'limit'};
1317         }
1318     }
1319
1320     $debug and warn "_get_unsent_messages SQL: $statement";
1321     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
1322     my $sth = $dbh->prepare( $statement );
1323     my $result = $sth->execute( @query_params );
1324     return $sth->fetchall_arrayref({});
1325 }
1326
1327 sub _send_message_by_email {
1328     my $message = shift or return;
1329     my ($username, $password, $method) = @_;
1330
1331     my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1332     my $to_address = $message->{'to_address'};
1333     unless ($to_address) {
1334         unless ($patron) {
1335             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
1336             _set_message_status( { message_id => $message->{'message_id'},
1337                                    status     => 'failed',
1338                                    delivery_note => 'Invalid borrowernumber '.$message->{borrowernumber} } );
1339             return;
1340         }
1341         $to_address = $patron->notice_email_address;
1342         unless ($to_address) {
1343             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
1344             # warning too verbose for this more common case?
1345             _set_message_status( { message_id => $message->{'message_id'},
1346                                    status     => 'failed',
1347                                    delivery_note => 'Unable to find an email address for this borrower' } );
1348             return;
1349         }
1350     }
1351
1352     my $subject = $message->{'subject'};
1353
1354     my $content = $message->{'content'};
1355     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
1356     my $is_html = $content_type =~ m/html/io;
1357
1358     my $branch_email = undef;
1359     my $branch_replyto = undef;
1360     my $branch_returnpath = undef;
1361     my $library;
1362
1363     if ($patron) {
1364         $library           = $patron->library;
1365         $branch_email      = $library->branchemail;
1366         $branch_replyto    = $library->branchreplyto;
1367         $branch_returnpath = $library->branchreturnpath;
1368     }
1369
1370     my $email = Koha::Email->create(
1371         {
1372             to => $to_address,
1373             (
1374                 C4::Context->preference('NoticeBcc')
1375                 ? ( bcc => C4::Context->preference('NoticeBcc') )
1376                 : ()
1377             ),
1378             from     => $message->{'from_address'}  || $branch_email,
1379             reply_to => $message->{'reply_address'} || $branch_replyto,
1380             sender   => $branch_returnpath,
1381             subject  => "" . $message->{subject}
1382         }
1383     );
1384
1385     if ( $is_html ) {
1386         $email->html_body(
1387             _wrap_html( $content, $subject )
1388         );
1389     }
1390     else {
1391         $email->text_body( $content );
1392     }
1393
1394     my $smtp_server;
1395     if ( $library ) {
1396         $smtp_server = $library->smtp_server;
1397     }
1398     else {
1399         $smtp_server = Koha::SMTP::Servers->get_default;
1400     }
1401
1402     if ( $username ) {
1403         $smtp_server->set(
1404             {
1405                 sasl_username => $username,
1406                 sasl_password => $password,
1407             }
1408         );
1409     }
1410
1411 # if initial message address was empty, coming here means that a to address was found and
1412 # queue should be updated; same if to address was overriden by Koha::Email->create
1413     _update_message_to_address( $message->{'message_id'}, $email->email->header('To') )
1414       if !$message->{to_address}
1415       || $message->{to_address} ne $email->email->header('To');
1416
1417     try {
1418         $email->send_or_die({ transport => $smtp_server->transport });
1419
1420         _set_message_status(
1421             {
1422                 message_id => $message->{'message_id'},
1423                 status     => 'sent',
1424                 delivery_note => ''
1425             }
1426         );
1427         return 1;
1428     }
1429     catch {
1430         _set_message_status(
1431             {
1432                 message_id => $message->{'message_id'},
1433                 status     => 'failed',
1434                 delivery_note => $Mail::Sendmail::error
1435             }
1436         );
1437         carp "$_";
1438         return;
1439     };
1440 }
1441
1442 sub _wrap_html {
1443     my ($content, $title) = @_;
1444
1445     my $css = C4::Context->preference("NoticeCSS") || '';
1446     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
1447     return <<EOS;
1448 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1449     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1450 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1451 <head>
1452 <title>$title</title>
1453 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1454 $css
1455 </head>
1456 <body>
1457 $content
1458 </body>
1459 </html>
1460 EOS
1461 }
1462
1463 sub _is_duplicate {
1464     my ( $message ) = @_;
1465     my $dbh = C4::Context->dbh;
1466     my $count = $dbh->selectrow_array(q|
1467         SELECT COUNT(*)
1468         FROM message_queue
1469         WHERE message_transport_type = ?
1470         AND borrowernumber = ?
1471         AND letter_code = ?
1472         AND CAST(updated_on AS date) = CAST(NOW() AS date)
1473         AND status="sent"
1474         AND content = ?
1475     |, {}, $message->{message_transport_type}, $message->{borrowernumber}, $message->{letter_code}, $message->{content} );
1476     return $count;
1477 }
1478
1479 sub _send_message_by_sms {
1480     my $message = shift or return;
1481     my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1482
1483     unless ( $patron and $patron->smsalertnumber ) {
1484         _set_message_status( { message_id => $message->{'message_id'},
1485                                status     => 'failed',
1486                                delivery_note => 'Missing SMS number' } );
1487         return;
1488     }
1489
1490     if ( _is_duplicate( $message ) ) {
1491         _set_message_status( { message_id => $message->{'message_id'},
1492                                status     => 'failed',
1493                                delivery_note => 'Message is duplicate' } );
1494         return;
1495     }
1496
1497     my $success = C4::SMS->send_sms( { destination => $patron->smsalertnumber,
1498                                        message     => $message->{'content'},
1499                                      } );
1500     _set_message_status( { message_id => $message->{'message_id'},
1501                            status     => ($success ? 'sent' : 'failed'),
1502                            delivery_note => ($success ? '' : 'No notes from SMS driver') } );
1503
1504     return $success;
1505 }
1506
1507 sub _update_message_to_address {
1508     my ($id, $to)= @_;
1509     my $dbh = C4::Context->dbh();
1510     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1511 }
1512
1513 sub _update_message_from_address {
1514     my ($message_id, $from_address) = @_;
1515     my $dbh = C4::Context->dbh();
1516     $dbh->do('UPDATE message_queue SET from_address = ? WHERE message_id = ?', undef, ($from_address, $message_id));
1517 }
1518
1519 sub _set_message_status {
1520     my $params = shift or return;
1521
1522     foreach my $required_parameter ( qw( message_id status ) ) {
1523         return unless exists $params->{ $required_parameter };
1524     }
1525
1526     my $dbh = C4::Context->dbh();
1527     my $statement = 'UPDATE message_queue SET status= ?, delivery_note= ? WHERE message_id = ?';
1528     my $sth = $dbh->prepare( $statement );
1529     my $result = $sth->execute( $params->{'status'},
1530                                 $params->{'delivery_note'} || '',
1531                                 $params->{'message_id'} );
1532     return $result;
1533 }
1534
1535 sub _process_tt {
1536     my ( $params ) = @_;
1537
1538     my $content = $params->{content};
1539     my $tables = $params->{tables};
1540     my $loops = $params->{loops};
1541     my $substitute = $params->{substitute} || {};
1542     my $lang = defined($params->{lang}) && $params->{lang} ne 'default' ? $params->{lang} : 'en';
1543     my ($theme, $activethemes);
1544
1545     my $htdocs = C4::Context->config('intrahtdocs');
1546     ($theme, $lang, $activethemes)= C4::Templates::activethemes( $htdocs, 'about.tt', 'intranet', $lang);
1547     my @includes;
1548     foreach (@$activethemes) {
1549         push @includes, "$htdocs/$_/$lang/includes";
1550         push @includes, "$htdocs/$_/en/includes" unless $lang eq 'en';
1551     }
1552
1553     my $use_template_cache = C4::Context->config('template_cache_dir') && defined $ENV{GATEWAY_INTERFACE};
1554     my $template           = Template->new(
1555         {
1556             EVAL_PERL    => 1,
1557             ABSOLUTE     => 1,
1558             PLUGIN_BASE  => 'Koha::Template::Plugin',
1559             COMPILE_EXT  => $use_template_cache ? '.ttc' : '',
1560             COMPILE_DIR  => $use_template_cache ? C4::Context->config('template_cache_dir') : '',
1561             INCLUDE_PATH => \@includes,
1562             FILTERS      => {},
1563             ENCODING     => 'UTF-8',
1564         }
1565     ) or die Template->error();
1566
1567     my $tt_params = { %{ _get_tt_params( $tables ) }, %{ _get_tt_params( $loops, 'is_a_loop' ) }, %$substitute };
1568
1569     $content = add_tt_filters( $content );
1570     $content = qq|[% USE KohaDates %][% USE Remove_MARC_punctuation %]$content|;
1571
1572     my $output;
1573     $template->process( \$content, $tt_params, \$output ) || croak "ERROR PROCESSING TEMPLATE: " . $template->error();
1574
1575     return $output;
1576 }
1577
1578 sub _get_tt_params {
1579     my ($tables, $is_a_loop) = @_;
1580
1581     my $params;
1582     $is_a_loop ||= 0;
1583
1584     my $config = {
1585         article_requests => {
1586             module   => 'Koha::ArticleRequests',
1587             singular => 'article_request',
1588             plural   => 'article_requests',
1589             pk       => 'id',
1590         },
1591         aqbasket => {
1592             module   => 'Koha::Acquisition::Baskets',
1593             singular => 'basket',
1594             plural   => 'baskets',
1595             pk       => 'basketno',
1596         },
1597         biblio => {
1598             module   => 'Koha::Biblios',
1599             singular => 'biblio',
1600             plural   => 'biblios',
1601             pk       => 'biblionumber',
1602         },
1603         biblioitems => {
1604             module   => 'Koha::Biblioitems',
1605             singular => 'biblioitem',
1606             plural   => 'biblioitems',
1607             pk       => 'biblioitemnumber',
1608         },
1609         borrowers => {
1610             module   => 'Koha::Patrons',
1611             singular => 'borrower',
1612             plural   => 'borrowers',
1613             pk       => 'borrowernumber',
1614         },
1615         branches => {
1616             module   => 'Koha::Libraries',
1617             singular => 'branch',
1618             plural   => 'branches',
1619             pk       => 'branchcode',
1620         },
1621         credits => {
1622             module => 'Koha::Account::Lines',
1623             singular => 'credit',
1624             plural => 'credits',
1625             pk => 'accountlines_id',
1626         },
1627         debits => {
1628             module => 'Koha::Account::Lines',
1629             singular => 'debit',
1630             plural => 'debits',
1631             pk => 'accountlines_id',
1632         },
1633         items => {
1634             module   => 'Koha::Items',
1635             singular => 'item',
1636             plural   => 'items',
1637             pk       => 'itemnumber',
1638         },
1639         opac_news => {
1640             module   => 'Koha::News',
1641             singular => 'news',
1642             plural   => 'news',
1643             pk       => 'idnew',
1644         },
1645         aqorders => {
1646             module   => 'Koha::Acquisition::Orders',
1647             singular => 'order',
1648             plural   => 'orders',
1649             pk       => 'ordernumber',
1650         },
1651         reserves => {
1652             module   => 'Koha::Holds',
1653             singular => 'hold',
1654             plural   => 'holds',
1655             pk       => 'reserve_id',
1656         },
1657         serial => {
1658             module   => 'Koha::Serials',
1659             singular => 'serial',
1660             plural   => 'serials',
1661             pk       => 'serialid',
1662         },
1663         subscription => {
1664             module   => 'Koha::Subscriptions',
1665             singular => 'subscription',
1666             plural   => 'subscriptions',
1667             pk       => 'subscriptionid',
1668         },
1669         suggestions => {
1670             module   => 'Koha::Suggestions',
1671             singular => 'suggestion',
1672             plural   => 'suggestions',
1673             pk       => 'suggestionid',
1674         },
1675         issues => {
1676             module   => 'Koha::Checkouts',
1677             singular => 'checkout',
1678             plural   => 'checkouts',
1679             fk       => 'itemnumber',
1680         },
1681         old_issues => {
1682             module   => 'Koha::Old::Checkouts',
1683             singular => 'old_checkout',
1684             plural   => 'old_checkouts',
1685             fk       => 'itemnumber',
1686         },
1687         overdues => {
1688             module   => 'Koha::Checkouts',
1689             singular => 'overdue',
1690             plural   => 'overdues',
1691             fk       => 'itemnumber',
1692         },
1693         borrower_modifications => {
1694             module   => 'Koha::Patron::Modifications',
1695             singular => 'patron_modification',
1696             plural   => 'patron_modifications',
1697             fk       => 'verification_token',
1698         },
1699         illrequests => {
1700             module   => 'Koha::Illrequests',
1701             singular => 'illrequest',
1702             plural   => 'illrequests',
1703             pk       => 'illrequest_id'
1704         }
1705     };
1706
1707     foreach my $table ( keys %$tables ) {
1708         next unless $config->{$table};
1709
1710         my $ref = ref( $tables->{$table} ) || q{};
1711         my $module = $config->{$table}->{module};
1712
1713         if ( can_load( modules => { $module => undef } ) ) {
1714             my $pk = $config->{$table}->{pk};
1715             my $fk = $config->{$table}->{fk};
1716
1717             if ( $is_a_loop ) {
1718                 my $values = $tables->{$table} || [];
1719                 unless ( ref( $values ) eq 'ARRAY' ) {
1720                     croak "ERROR processing table $table. Wrong API call.";
1721                 }
1722                 my $key = $pk ? $pk : $fk;
1723                 # $key does not come from user input
1724                 my $objects = $module->search(
1725                     { $key => $values },
1726                     {
1727                             # We want to retrieve the data in the same order
1728                             # FIXME MySQLism
1729                             # field is a MySQLism, but they are no other way to do it
1730                             # To be generic we could do it in perl, but we will need to fetch
1731                             # all the data then order them
1732                         @$values ? ( order_by => \[ "field($key, " . join( ', ', @$values ) . ")" ] ) : ()
1733                     }
1734                 );
1735                 $params->{ $config->{$table}->{plural} } = $objects;
1736             }
1737             elsif ( $ref eq q{} || $ref eq 'HASH' ) {
1738                 my $id = ref $ref eq 'HASH' ? $tables->{$table}->{$pk} : $tables->{$table};
1739                 my $object;
1740                 if ( $fk ) { # Using a foreign key for lookup
1741                     if ( ref( $fk ) eq 'ARRAY' ) { # Foreign key is multi-column
1742                         my $search;
1743                         foreach my $key ( @$fk ) {
1744                             $search->{$key} = $id->{$key};
1745                         }
1746                         $object = $module->search( $search )->last();
1747                     } else { # Foreign key is single column
1748                         $object = $module->search( { $fk => $id } )->last();
1749                     }
1750                 } else { # using the table's primary key for lookup
1751                     $object = $module->find($id);
1752                 }
1753                 $params->{ $config->{$table}->{singular} } = $object;
1754             }
1755             else {    # $ref eq 'ARRAY'
1756                 my $object;
1757                 if ( @{ $tables->{$table} } == 1 ) {    # Param is a single key
1758                     $object = $module->search( { $pk => $tables->{$table} } )->last();
1759                 }
1760                 else {                                  # Params are mutliple foreign keys
1761                     croak "Multiple foreign keys (table $table) should be passed using an hashref";
1762                 }
1763                 $params->{ $config->{$table}->{singular} } = $object;
1764             }
1765         }
1766         else {
1767             croak "ERROR LOADING MODULE $module: $Module::Load::Conditional::ERROR";
1768         }
1769     }
1770
1771     $params->{today} = output_pref({ dt => dt_from_string, dateformat => 'iso' });
1772
1773     return $params;
1774 }
1775
1776 =head3 add_tt_filters
1777
1778 $content = add_tt_filters( $content );
1779
1780 Add TT filters to some specific fields if needed.
1781
1782 For now we only add the Remove_MARC_punctuation TT filter to biblio and biblioitem fields
1783
1784 =cut
1785
1786 sub add_tt_filters {
1787     my ( $content ) = @_;
1788     $content =~ s|\[%\s*biblio\.(.*?)\s*%\]|[% biblio.$1 \| \$Remove_MARC_punctuation %]|gxms;
1789     $content =~ s|\[%\s*biblioitem\.(.*?)\s*%\]|[% biblioitem.$1 \| \$Remove_MARC_punctuation %]|gxms;
1790     return $content;
1791 }
1792
1793 =head2 get_item_content
1794
1795     my $item = Koha::Items->find(...)->unblessed;
1796     my @item_content_fields = qw( date_due title barcode author itemnumber );
1797     my $item_content = C4::Letters::get_item_content({
1798                              item => $item,
1799                              item_content_fields => \@item_content_fields
1800                        });
1801
1802 This function generates a tab-separated list of values for the passed item. Dates
1803 are formatted following the current setup.
1804
1805 =cut
1806
1807 sub get_item_content {
1808     my ( $params ) = @_;
1809     my $item = $params->{item};
1810     my $dateonly = $params->{dateonly} || 0;
1811     my $item_content_fields = $params->{item_content_fields} || [];
1812
1813     return unless $item;
1814
1815     my @item_info = map {
1816         $_ =~ /^date|date$/
1817           ? eval {
1818             output_pref(
1819                 { dt => dt_from_string( $item->{$_} ), dateonly => $dateonly } );
1820           }
1821           : $item->{$_}
1822           || ''
1823     } @$item_content_fields;
1824     return join( "\t", @item_info ) . "\n";
1825 }
1826
1827 1;
1828 __END__