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         my $module = $action eq 'ACQUISITION ORDER' ? 'ACQUISITIONS' : 'CLAIMS';
 538         logaction(
 539             $module,
 540             $action,
 541             undef,
 542             "To="
 543                 . join( ',', @email )
 544                 . " Title="
 545                 . $letter->{title}
 546                 . " Content="
 547                 . $letter->{content}
 548         ) if C4::Context->preference("ClaimsLog");
 549     }
 550    # send an "account details" notice to a newly created user
 551     elsif ( $type eq 'members' ) {
 552         my $library = Koha::Libraries->find( $externalid->{branchcode} );
 553         my $letter = GetPreparedLetter (
 554             module => 'members',
 555             letter_code => $letter_code,
 556             branchcode => $externalid->{'branchcode'},
 557             lang       => $externalid->{lang} || 'default',
 558             tables => {
 559                 'branches'    => $library->unblessed,
 560                 'borrowers' => $externalid->{'borrowernumber'},
 561             },
 562             substitute => { 'borrowers.password' => $externalid->{'password'} },
 563             want_librarian => 1,
 564         ) or return;
 565         return { error => "no_email" } unless $externalid->{'emailaddr'};
 566
 567         my $success = try {
 568
 569             # FIXME: This 'default' behaviour should be moved to Koha::Email
 570             my $mail = Koha::Email->create(
 571                 {
 572                     to       => $externalid->{'emailaddr'},
 573                     from     => $library->branchemail,
 574                     reply_to => $library->branchreplyto,
 575                     sender   => $library->branchreturnpath,
 576                     subject  => "" . $letter->{'title'},
 577                 }
 578             );
 579
 580             if ( $letter->{is_html} ) {
 581                 $mail->html_body( _wrap_html( $letter->{content}, "" . $letter->{title} ) );
 582             }
 583             else {
 584                 $mail->text_body( $letter->{content} );
 585             }
 586
 587             $mail->send_or_die({ transport => $library->smtp_server->transport });
 588         }
 589         catch {
 590             # We expect ref($_) eq 'Email::Sender::Failure'
 591             $error = $_->message;
 592
 593             carp "$_";
 594             return;
 595         };
 596
 597         return { error => $error }
 598             unless $success;
 599     }
 600
 601     # If we come here, return an OK status
 602     return 1;
 603 }
 604
 605 =head2 GetPreparedLetter( %params )
 606
 607     %params hash:
 608       module => letter module, mandatory
 609       letter_code => letter code, mandatory
 610       branchcode => for letter selection, if missing default system letter taken
 611       tables => a hashref with table names as keys. Values are either:
 612         - a scalar - primary key value
 613         - an arrayref - primary key values
 614         - a hashref - full record
 615       substitute => custom substitution key/value pairs
 616       repeat => records to be substituted on consecutive lines:
 617         - an arrayref - tries to guess what needs substituting by
 618           taking remaining << >> tokensr; not recommended
 619         - a hashref token => @tables - replaces <token> << >> << >> </token>
 620           subtemplate for each @tables row; table is a hashref as above
 621       want_librarian => boolean,  if set to true triggers librarian details
 622         substitution from the userenv
 623     Return value:
 624       letter fields hashref (title & content useful)
 625
 626 =cut
 627
 628 sub GetPreparedLetter {
 629     my %params = @_;
 630
 631     my $letter = $params{letter};
 632     my $lang   = $params{lang} || 'default';
 633
 634     unless ( $letter ) {
 635         my $module      = $params{module} or croak "No module";
 636         my $letter_code = $params{letter_code} or croak "No letter_code";
 637         my $branchcode  = $params{branchcode} || '';
 638         my $mtt         = $params{message_transport_type} || 'email';
 639
 640         $letter = getletter( $module, $letter_code, $branchcode, $mtt, $lang );
 641
 642         unless ( $letter ) {
 643             $letter = getletter( $module, $letter_code, $branchcode, $mtt, 'default' )
 644                 or warn( "No $module $letter_code letter transported by " . $mtt ),
 645                     return;
 646         }
 647     }
 648
 649     my $tables = $params{tables} || {};
 650     my $substitute = $params{substitute} || {};
 651     my $loops  = $params{loops} || {}; # loops is not supported for historical notices syntax
 652     my $repeat = $params{repeat};
 653     %$tables || %$substitute || $repeat || %$loops
 654       or carp( "ERROR: nothing to substitute - both 'tables', 'loops' and 'substitute' are empty" ),
 655          return;
 656     my $want_librarian = $params{want_librarian};
 657
 658     if (%$substitute) {
 659         while ( my ($token, $val) = each %$substitute ) {
 660             if ( $token eq 'items.content' ) {
 661                 $val =~ s|\n|<br/>|g if $letter->{is_html};
 662             }
 663
 664             $letter->{title} =~ s/<<$token>>/$val/g;
 665             $letter->{content} =~ s/<<$token>>/$val/g;
 666        }
 667     }
 668
 669     my $OPACBaseURL = C4::Context->preference('OPACBaseURL');
 670     $letter->{content} =~ s/<<OPACBaseURL>>/$OPACBaseURL/go;
 671
 672     if ($want_librarian) {
 673         # parsing librarian name
 674         my $userenv = C4::Context->userenv;
 675         $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/go;
 676         $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/go;
 677         $letter->{content} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/go;
 678     }
 679
 680     my ($repeat_no_enclosing_tags, $repeat_enclosing_tags);
 681
 682     if ($repeat) {
 683         if (ref ($repeat) eq 'ARRAY' ) {
 684             $repeat_no_enclosing_tags = $repeat;
 685         } else {
 686             $repeat_enclosing_tags = $repeat;
 687         }
 688     }
 689
 690     if ($repeat_enclosing_tags) {
 691         while ( my ($tag, $tag_tables) = each %$repeat_enclosing_tags ) {
 692             if ( $letter->{content} =~ m!<$tag>(.*)</$tag>!s ) {
 693                 my $subcontent = $1;
 694                 my @lines = map {
 695                     my %subletter = ( title => '', content => $subcontent );
 696                     _substitute_tables( \%subletter, $_ );
 697                     $subletter{content};
 698                 } @$tag_tables;
 699                 $letter->{content} =~ s!<$tag>.*</$tag>!join( "\n", @lines )!se;
 700             }
 701         }
 702     }
 703
 704     if (%$tables) {
 705         _substitute_tables( $letter, $tables );
 706     }
 707
 708     if ($repeat_no_enclosing_tags) {
 709         if ( $letter->{content} =~ m/[^\n]*<<.*>>[^\n]*/so ) {
 710             my $line = $&;
 711             my $i = 1;
 712             my @lines = map {
 713                 my $c = $line;
 714                 $c =~ s/<<count>>/$i/go;
 715                 foreach my $field ( keys %{$_} ) {
 716                     $c =~ s/(<<[^\.]+.$field>>)/$_->{$field}/;
 717                 }
 718                 $i++;
 719                 $c;
 720             } @$repeat_no_enclosing_tags;
 721
 722             my $replaceby = join( "\n", @lines );
 723             $letter->{content} =~ s/\Q$line\E/$replaceby/s;
 724         }
 725     }
 726
 727     $letter->{content} = _process_tt(
 728         {
 729             content => $letter->{content},
 730             tables  => $tables,
 731             loops  => $loops,
 732             substitute => $substitute,
 733             lang => $lang
 734         }
 735     );
 736
 737     $letter->{title} = _process_tt(
 738         {
 739             content => $letter->{title},
 740             tables  => $tables,
 741             loops  => $loops,
 742             substitute => $substitute,
 743         }
 744     );
 745
 746     $letter->{content} =~ s/<<\S*>>//go; #remove any stragglers
 747
 748     return $letter;
 749 }
 750
 751 sub _substitute_tables {
 752     my ( $letter, $tables ) = @_;
 753     while ( my ($table, $param) = each %$tables ) {
 754         next unless $param;
 755
 756         my $ref = ref $param;
 757
 758         my $values;
 759         if ($ref && $ref eq 'HASH') {
 760             $values = $param;
 761         }
 762         else {
 763             my $sth = _parseletter_sth($table);
 764             unless ($sth) {
 765                 warn "_parseletter_sth('$table') failed to return a valid sth.  No substitution will be done for that table.";
 766                 return;
 767             }
 768             $sth->execute( $ref ? @$param : $param );
 769
 770             $values = $sth->fetchrow_hashref;
 771             $sth->finish();
 772         }
 773
 774         _parseletter ( $letter, $table, $values );
 775     }
 776 }
 777
 778 sub _parseletter_sth {
 779     my $table = shift;
 780     my $sth;
 781     unless ($table) {
 782         carp "ERROR: _parseletter_sth() called without argument (table)";
 783         return;
 784     }
 785     # NOTE: we used to check whether we had a statement handle cached in
 786     #       a %handles module-level variable. This was a dumb move and
 787     #       broke things for the rest of us. prepare_cached is a better
 788     #       way to cache statement handles anyway.
 789     my $query =
 790     ($table eq 'accountlines' )    ? "SELECT * FROM $table WHERE   accountlines_id = ?"                               :
 791     ($table eq 'biblio'       )    ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 792     ($table eq 'biblioitems'  )    ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 793     ($table eq 'credits'      )    ? "SELECT * FROM accountlines WHERE   accountlines_id = ?"                         :
 794     ($table eq 'debits'       )    ? "SELECT * FROM accountlines WHERE   accountlines_id = ?"                         :
 795     ($table eq 'items'        )    ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 796     ($table eq 'issues'       )    ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 797     ($table eq 'old_issues'   )    ? "SELECT * FROM $table WHERE     itemnumber = ? ORDER BY timestamp DESC LIMIT 1"  :
 798     ($table eq 'reserves'     )    ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?"             :
 799     ($table eq 'borrowers'    )    ? "SELECT * FROM $table WHERE borrowernumber = ?"                                  :
 800     ($table eq 'branches'     )    ? "SELECT * FROM $table WHERE     branchcode = ?"                                  :
 801     ($table eq 'suggestions'  )    ? "SELECT * FROM $table WHERE   suggestionid = ?"                                  :
 802     ($table eq 'aqbooksellers')    ? "SELECT * FROM $table WHERE             id = ?"                                  :
 803     ($table eq 'aqorders'     )    ? "SELECT * FROM $table WHERE    ordernumber = ?"                                  :
 804     ($table eq 'aqbasket'     )    ? "SELECT * FROM $table WHERE       basketno = ?"                                  :
 805     ($table eq 'illrequests'  )    ? "SELECT * FROM $table WHERE  illrequest_id = ?"                                  :
 806     ($table eq 'opac_news'    )    ? "SELECT * FROM $table WHERE          idnew = ?"                                  :
 807     ($table eq 'article_requests') ? "SELECT * FROM $table WHERE             id = ?"                                  :
 808     ($table eq 'borrower_modifications') ? "SELECT * FROM $table WHERE verification_token = ?" :
 809     ($table eq 'subscription') ? "SELECT * FROM $table WHERE subscriptionid = ?" :
 810     ($table eq 'serial') ? "SELECT * FROM $table WHERE serialid = ?" :
 811     ($table eq 'problem_reports') ? "SELECT * FROM $table WHERE reportid = ?" :
 812     undef ;
 813     unless ($query) {
 814         warn "ERROR: No _parseletter_sth query for table '$table'";
 815         return;     # nothing to get
 816     }
 817     unless ($sth = C4::Context->dbh->prepare_cached($query)) {
 818         warn "ERROR: Failed to prepare query: '$query'";
 819         return;
 820     }
 821     return $sth;    # now cache is populated for that $table
 822 }
 823
 824 =head2 _parseletter($letter, $table, $values)
 825
 826     parameters :
 827     - $letter : a hash to letter fields (title & content useful)
 828     - $table : the Koha table to parse.
 829     - $values_in : table record hashref
 830     parse all fields from a table, and replace values in title & content with the appropriate value
 831     (not exported sub, used only internally)
 832
 833 =cut
 834
 835 sub _parseletter {
 836     my ( $letter, $table, $values_in ) = @_;
 837
 838     # Work on a local copy of $values_in (passed by reference) to avoid side effects
 839     # in callers ( by changing / formatting values )
 840     my $values = $values_in ? { %$values_in } : {};
 841
 842     if ( $table eq 'borrowers' && $values->{'dateexpiry'} ){
 843         $values->{'dateexpiry'} = output_pref({ dt => dt_from_string( $values->{'dateexpiry'} ), dateonly => 1 });
 844     }
 845
 846     if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
 847         $values->{'waitingdate'} = output_pref({ dt => dt_from_string( $values->{'waitingdate'} ), dateonly => 1 });
 848     }
 849
 850     if ($letter->{content} && $letter->{content} =~ /<<today>>/) {
 851         my $todaysdate = output_pref( dt_from_string() );
 852         $letter->{content} =~ s/<<today>>/$todaysdate/go;
 853     }
 854
 855     while ( my ($field, $val) = each %$values ) {
 856         $val =~ s/\p{P}$// if $val && $table=~/biblio/;
 857             #BZ 9886: Assuming that we want to eliminate ISBD punctuation here
 858             #Therefore adding the test on biblio. This includes biblioitems,
 859             #but excludes items. Removed unneeded global and lookahead.
 860
 861         if ( $table=~/^borrowers$/ && $field=~/^streettype$/ ) {
 862             my $av = Koha::AuthorisedValues->search({ category => 'ROADTYPE', authorised_value => $val });
 863             $val = $av->count ? $av->next->lib : '';
 864         }
 865
 866         # Dates replacement
 867         my $replacedby   = defined ($val) ? $val : '';
 868         if (    $replacedby
 869             and not $replacedby =~ m|9999-12-31|
 870             and $replacedby =~ m|^\d{4}-\d{2}-\d{2}( \d{2}:\d{2}:\d{2})?$| )
 871         {
 872             # If the value is XXXX-YY-ZZ[ AA:BB:CC] we assume it is a date
 873             my $dateonly = defined $1 ? 0 : 1; #$1 refers to the capture group wrapped in parentheses. In this case, that's the hours, minutes, seconds.
 874             my $re_dateonly_filter = qr{ $field( \s* \| \s* dateonly\s*)?>> }xms;
 875
 876             for my $letter_field ( qw( title content ) ) {
 877                 my $filter_string_used = q{};
 878                 if ( $letter->{ $letter_field } =~ $re_dateonly_filter ) {
 879                     # We overwrite $dateonly if the filter exists and we have a time in the datetime
 880                     $filter_string_used = $1 || q{};
 881                     $dateonly = $1 unless $dateonly;
 882                 }
 883                 my $replacedby_date = eval {
 884                     output_pref({ dt => dt_from_string( $replacedby ), dateonly => $dateonly });
 885                 };
 886
 887                 if ( $letter->{ $letter_field } ) {
 888                     $letter->{ $letter_field } =~ s/\Q<<$table.$field$filter_string_used>>\E/$replacedby_date/g;
 889                     $letter->{ $letter_field } =~ s/\Q<<$field$filter_string_used>>\E/$replacedby_date/g;
 890                 }
 891             }
 892         }
 893         # Other fields replacement
 894         else {
 895             for my $letter_field ( qw( title content ) ) {
 896                 if ( $letter->{ $letter_field } ) {
 897                     $letter->{ $letter_field }   =~ s/<<$table.$field>>/$replacedby/g;
 898                     $letter->{ $letter_field }   =~ s/<<$field>>/$replacedby/g;
 899                 }
 900             }
 901         }
 902     }
 903
 904     if ($table eq 'borrowers' && $letter->{content}) {
 905         my $patron = Koha::Patrons->find( $values->{borrowernumber} );
 906         if ( $patron ) {
 907             my $attributes = $patron->extended_attributes;
 908             my %attr;
 909             while ( my $attribute = $attributes->next ) {
 910                 my $code = $attribute->code;
 911                 my $val  = $attribute->description; # FIXME - we always display intranet description here!
 912                 $val =~ s/\p{P}(?=$)//g if $val;
 913                 next unless $val gt '';
 914                 $attr{$code} ||= [];
 915                 push @{ $attr{$code} }, $val;
 916             }
 917             while ( my ($code, $val_ar) = each %attr ) {
 918                 my $replacefield = "<<borrower-attribute:$code>>";
 919                 my $replacedby   = join ',', @$val_ar;
 920                 $letter->{content} =~ s/$replacefield/$replacedby/g;
 921             }
 922         }
 923     }
 924     return $letter;
 925 }
 926
 927 =head2 EnqueueLetter
 928
 929   my $success = EnqueueLetter( { letter => $letter,
 930         borrowernumber => '12', message_transport_type => 'email' } )
 931
 932 places a letter in the message_queue database table, which will
 933 eventually get processed (sent) by the process_message_queue.pl
 934 cronjob when it calls SendQueuedMessages.
 935
 936 return message_id on success
 937
 938 =cut
 939
 940 sub EnqueueLetter {
 941     my $params = shift or return;
 942
 943     return unless exists $params->{'letter'};
 944 #   return unless exists $params->{'borrowernumber'};
 945     return unless exists $params->{'message_transport_type'};
 946
 947     my $content = $params->{letter}->{content};
 948     $content =~ s/\s+//g if(defined $content);
 949     if ( not defined $content or $content eq '' ) {
 950         warn "Trying to add an empty message to the message queue" if $debug;
 951         return;
 952     }
 953
 954     # If we have any attachments we should encode then into the body.
 955     if ( $params->{'attachments'} ) {
 956         $params->{'letter'} = _add_attachments(
 957             {   letter      => $params->{'letter'},
 958                 attachments => $params->{'attachments'},
 959                 message     => MIME::Lite->new( Type => 'multipart/mixed' ),
 960             }
 961         );
 962     }
 963
 964     my $dbh       = C4::Context->dbh();
 965     my $statement = << 'ENDSQL';
 966 INSERT INTO message_queue
 967 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, reply_address, content_type, delivery_note )
 968 VALUES
 969 ( ?,              ?,       ?,       ?,        ?,           ?,                      ?,      CAST(NOW() AS DATETIME),       ?,          ?,            ?,           ?,              ? )
 970 ENDSQL
 971
 972     my $sth    = $dbh->prepare($statement);
 973     my $result = $sth->execute(
 974         $params->{'borrowernumber'},              # borrowernumber
 975         $params->{'letter'}->{'title'},           # subject
 976         $params->{'letter'}->{'content'},         # content
 977         $params->{'letter'}->{'metadata'} || '',  # metadata
 978         $params->{'letter'}->{'code'}     || '',  # letter_code
 979         $params->{'message_transport_type'},      # message_transport_type
 980         'pending',                                # status
 981         $params->{'to_address'},                  # to_address
 982         $params->{'from_address'},                # from_address
 983         $params->{'reply_address'},               # reply_address
 984         $params->{'letter'}->{'content-type'},    # content_type
 985         $params->{'delivery_note'}        || '',  # delivery_note
 986     );
 987     return $dbh->last_insert_id(undef,undef,'message_queue', undef);
 988 }
 989
 990 =head2 SendQueuedMessages ([$hashref])
 991
 992     my $sent = SendQueuedMessages({
 993         letter_code => $letter_code,
 994         borrowernumber => $who_letter_is_for,
 995         limit => 50,
 996         verbose => 1,
 997         type => 'sms',
 998     });
 999
1000 Sends all of the 'pending' items in the message queue, unless
1001 parameters are passed.
1002
1003 The letter_code, borrowernumber and limit parameters are used
1004 to build a parameter set for _get_unsent_messages, thus limiting
1005 which pending messages will be processed. They are all optional.
1006
1007 The verbose parameter can be used to generate debugging output.
1008 It is also optional.
1009
1010 Returns number of messages sent.
1011
1012 =cut
1013
1014 sub SendQueuedMessages {
1015     my $params = shift;
1016
1017     my $which_unsent_messages  = {
1018         'message_id'     => $params->{'message_id'},
1019         'limit'          => $params->{'limit'} // 0,
1020         'borrowernumber' => $params->{'borrowernumber'} // q{},
1021         'letter_code'    => $params->{'letter_code'} // q{},
1022         'type'           => $params->{'type'} // q{},
1023     };
1024     my $unsent_messages = _get_unsent_messages( $which_unsent_messages );
1025     MESSAGE: foreach my $message ( @$unsent_messages ) {
1026         my $message_object = Koha::Notice::Messages->find( $message->{message_id} );
1027         # If this fails the database is unwritable and we won't manage to send a message that continues to be marked 'pending'
1028         $message_object->make_column_dirty('status');
1029         return unless $message_object->store;
1030
1031         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
1032         warn sprintf( 'sending %s message to patron: %s',
1033                       $message->{'message_transport_type'},
1034                       $message->{'borrowernumber'} || 'Admin' )
1035           if $params->{'verbose'} or $debug;
1036         # This is just begging for subclassing
1037         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
1038         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
1039             _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
1040         }
1041         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
1042             if ( C4::Context->preference('SMSSendDriver') eq 'Email' ) {
1043                 my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1044                 my $sms_provider = Koha::SMS::Providers->find( $patron->sms_provider_id );
1045                 unless ( $sms_provider ) {
1046                     warn sprintf( "Patron %s has no sms provider id set!", $message->{'borrowernumber'} ) if $params->{'verbose'} or $debug;
1047                     _set_message_status( { message_id => $message->{'message_id'}, status => 'failed' } );
1048                     next MESSAGE;
1049                 }
1050                 unless ( $patron->smsalertnumber ) {
1051                     _set_message_status( { message_id => $message->{'message_id'}, status => 'failed' } );
1052                     warn sprintf( "No smsalertnumber found for patron %s!", $message->{'borrowernumber'} ) if $params->{'verbose'} or $debug;
1053                     next MESSAGE;
1054                 }
1055                 $message->{to_address}  = $patron->smsalertnumber; #Sometime this is set to email - sms should always use smsalertnumber
1056                 $message->{to_address} .= '@' . $sms_provider->domain();
1057
1058                 # Check for possible from_address override
1059                 my $from_address = C4::Context->preference('EmailSMSSendDriverFromAddress');
1060                 if ($from_address && $message->{from_address} ne $from_address) {
1061                     $message->{from_address} = $from_address;
1062                     _update_message_from_address($message->{'message_id'}, $message->{from_address});
1063                 }
1064
1065                 _update_message_to_address($message->{'message_id'}, $message->{to_address});
1066                 _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
1067             } else {
1068                 _send_message_by_sms( $message );
1069             }
1070         }
1071     }
1072     return scalar( @$unsent_messages );
1073 }
1074
1075 =head2 GetRSSMessages
1076
1077   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
1078
1079 returns a listref of all queued RSS messages for a particular person.
1080
1081 =cut
1082
1083 sub GetRSSMessages {
1084     my $params = shift;
1085
1086     return unless $params;
1087     return unless ref $params;
1088     return unless $params->{'borrowernumber'};
1089
1090     return _get_unsent_messages( { message_transport_type => 'rss',
1091                                    limit                  => $params->{'limit'},
1092                                    borrowernumber         => $params->{'borrowernumber'}, } );
1093 }
1094
1095 =head2 GetPrintMessages
1096
1097   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
1098
1099 Returns a arrayref of all queued print messages (optionally, for a particular
1100 person).
1101
1102 =cut
1103
1104 sub GetPrintMessages {
1105     my $params = shift || {};
1106
1107     return _get_unsent_messages( { message_transport_type => 'print',
1108                                    borrowernumber         => $params->{'borrowernumber'},
1109                                  } );
1110 }
1111
1112 =head2 GetQueuedMessages ([$hashref])
1113
1114   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
1115
1116 Fetches a list of messages from the message queue optionally filtered by borrowernumber
1117 and limited to specified limit.
1118
1119 Return is an arrayref of hashes, each has represents a message in the message queue.
1120
1121 =cut
1122
1123 sub GetQueuedMessages {
1124     my $params = shift;
1125
1126     my $dbh = C4::Context->dbh();
1127     my $statement = << 'ENDSQL';
1128 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued, updated_on, delivery_note
1129 FROM message_queue
1130 ENDSQL
1131
1132     my @query_params;
1133     my @whereclauses;
1134     if ( exists $params->{'borrowernumber'} ) {
1135         push @whereclauses, ' borrowernumber = ? ';
1136         push @query_params, $params->{'borrowernumber'};
1137     }
1138
1139     if ( @whereclauses ) {
1140         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
1141     }
1142
1143     if ( defined $params->{'limit'} ) {
1144         $statement .= ' LIMIT ? ';
1145         push @query_params, $params->{'limit'};
1146     }
1147
1148     my $sth = $dbh->prepare( $statement );
1149     my $result = $sth->execute( @query_params );
1150     return $sth->fetchall_arrayref({});
1151 }
1152
1153 =head2 GetMessageTransportTypes
1154
1155   my @mtt = GetMessageTransportTypes();
1156
1157   returns an arrayref of transport types
1158
1159 =cut
1160
1161 sub GetMessageTransportTypes {
1162     my $dbh = C4::Context->dbh();
1163     my $mtts = $dbh->selectcol_arrayref("
1164         SELECT message_transport_type
1165         FROM message_transport_types
1166         ORDER BY message_transport_type
1167     ");
1168     return $mtts;
1169 }
1170
1171 =head2 GetMessage
1172
1173     my $message = C4::Letters::Message($message_id);
1174
1175 =cut
1176
1177 sub GetMessage {
1178     my ( $message_id ) = @_;
1179     return unless $message_id;
1180     my $dbh = C4::Context->dbh;
1181     return $dbh->selectrow_hashref(q|
1182         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
1183         FROM message_queue
1184         WHERE message_id = ?
1185     |, {}, $message_id );
1186 }
1187
1188 =head2 ResendMessage
1189
1190   Attempt to resend a message which has failed previously.
1191
1192   my $has_been_resent = C4::Letters::ResendMessage($message_id);
1193
1194   Updates the message to 'pending' status so that
1195   it will be resent later on.
1196
1197   returns 1 on success, 0 on failure, undef if no message was found
1198
1199 =cut
1200
1201 sub ResendMessage {
1202     my $message_id = shift;
1203     return unless $message_id;
1204
1205     my $message = GetMessage( $message_id );
1206     return unless $message;
1207     my $rv = 0;
1208     if ( $message->{status} ne 'pending' ) {
1209         $rv = C4::Letters::_set_message_status({
1210             message_id => $message_id,
1211             status => 'pending',
1212         });
1213         $rv = $rv > 0? 1: 0;
1214         # Clear destination email address to force address update
1215         _update_message_to_address( $message_id, undef ) if $rv &&
1216             $message->{message_transport_type} eq 'email';
1217     }
1218     return $rv;
1219 }
1220
1221 =head2 _add_attachements
1222
1223   named parameters:
1224   letter - the standard letter hashref
1225   attachments - listref of attachments. each attachment is a hashref of:
1226     type - the mime type, like 'text/plain'
1227     content - the actual attachment
1228     filename - the name of the attachment.
1229   message - a MIME::Lite object to attach these to.
1230
1231   returns your letter object, with the content updated.
1232
1233 =cut
1234
1235 sub _add_attachments {
1236     my $params = shift;
1237
1238     my $letter = $params->{'letter'};
1239     my $attachments = $params->{'attachments'};
1240     return $letter unless @$attachments;
1241     my $message = $params->{'message'};
1242
1243     # First, we have to put the body in as the first attachment
1244     $message->attach(
1245         Type => $letter->{'content-type'} || 'TEXT',
1246         Data => $letter->{'is_html'}
1247             ? _wrap_html($letter->{'content'}, $letter->{'title'})
1248             : $letter->{'content'},
1249     );
1250
1251     foreach my $attachment ( @$attachments ) {
1252         $message->attach(
1253             Type     => $attachment->{'type'},
1254             Data     => $attachment->{'content'},
1255             Filename => $attachment->{'filename'},
1256         );
1257     }
1258     # we're forcing list context here to get the header, not the count back from grep.
1259     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
1260     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
1261     $letter->{'content'} = $message->body_as_string;
1262
1263     return $letter;
1264
1265 }
1266
1267 =head2 _get_unsent_messages
1268
1269   This function's parameter hash reference takes the following
1270   optional named parameters:
1271    message_transport_type: method of message sending (e.g. email, sms, etc.)
1272    borrowernumber        : who the message is to be sent
1273    letter_code           : type of message being sent (e.g. PASSWORD_RESET)
1274    message_id            : the message_id of the message. In that case the sub will return only 1 result
1275    limit                 : maximum number of messages to send
1276
1277   This function returns an array of matching hash referenced rows from
1278   message_queue with some borrower information added.
1279
1280 =cut
1281
1282 sub _get_unsent_messages {
1283     my $params = shift;
1284
1285     my $dbh = C4::Context->dbh();
1286     my $statement = qq{
1287         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
1288         FROM message_queue mq
1289         LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
1290         WHERE status = ?
1291     };
1292
1293     my @query_params = ('pending');
1294     if ( ref $params ) {
1295         if ( $params->{'message_transport_type'} ) {
1296             $statement .= ' AND mq.message_transport_type = ? ';
1297             push @query_params, $params->{'message_transport_type'};
1298         }
1299         if ( $params->{'borrowernumber'} ) {
1300             $statement .= ' AND mq.borrowernumber = ? ';
1301             push @query_params, $params->{'borrowernumber'};
1302         }
1303         if ( $params->{'letter_code'} ) {
1304             $statement .= ' AND mq.letter_code = ? ';
1305             push @query_params, $params->{'letter_code'};
1306         }
1307         if ( $params->{'type'} ) {
1308             $statement .= ' AND message_transport_type = ? ';
1309             push @query_params, $params->{'type'};
1310         }
1311         if ( $params->{message_id} ) {
1312             $statement .= ' AND message_id = ?';
1313             push @query_params, $params->{message_id};
1314         }
1315         if ( $params->{'limit'} ) {
1316             $statement .= ' limit ? ';
1317             push @query_params, $params->{'limit'};
1318         }
1319     }
1320
1321     $debug and warn "_get_unsent_messages SQL: $statement";
1322     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
1323     my $sth = $dbh->prepare( $statement );
1324     my $result = $sth->execute( @query_params );
1325     return $sth->fetchall_arrayref({});
1326 }
1327
1328 sub _send_message_by_email {
1329     my $message = shift or return;
1330     my ($username, $password, $method) = @_;
1331
1332     my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1333     my $to_address = $message->{'to_address'};
1334     unless ($to_address) {
1335         unless ($patron) {
1336             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
1337             _set_message_status( { message_id => $message->{'message_id'},
1338                                    status     => 'failed',
1339                                    delivery_note => 'Invalid borrowernumber '.$message->{borrowernumber},
1340                                    error_code => 'INVALID_BORNUMBER' } );
1341             return;
1342         }
1343         $to_address = $patron->notice_email_address;
1344         unless ($to_address) {
1345             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
1346             # warning too verbose for this more common case?
1347             _set_message_status( { message_id => $message->{'message_id'},
1348                                    status     => 'failed',
1349                                    delivery_note => 'Unable to find an email address for this borrower',
1350                                    error_code => 'NO_EMAIL' } );
1351             return;
1352         }
1353     }
1354
1355     my $subject = $message->{'subject'};
1356
1357     my $content = $message->{'content'};
1358     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
1359     my $is_html = $content_type =~ m/html/io;
1360
1361     my $branch_email = undef;
1362     my $branch_replyto = undef;
1363     my $branch_returnpath = undef;
1364     my $library;
1365
1366     if ($patron) {
1367         $library           = $patron->library;
1368         $branch_email      = $library->branchemail;
1369         $branch_replyto    = $library->branchreplyto;
1370         $branch_returnpath = $library->branchreturnpath;
1371     }
1372
1373     my $email = Koha::Email->create(
1374         {
1375             to => $to_address,
1376             (
1377                 C4::Context->preference('NoticeBcc')
1378                 ? ( bcc => C4::Context->preference('NoticeBcc') )
1379                 : ()
1380             ),
1381             from     => $message->{'from_address'}  || $branch_email,
1382             reply_to => $message->{'reply_address'} || $branch_replyto,
1383             sender   => $branch_returnpath,
1384             subject  => "" . $message->{subject}
1385         }
1386     );
1387
1388     if ( $is_html ) {
1389         $email->html_body(
1390             _wrap_html( $content, $subject )
1391         );
1392     }
1393     else {
1394         $email->text_body( $content );
1395     }
1396
1397     my $smtp_server;
1398     if ( $library ) {
1399         $smtp_server = $library->smtp_server;
1400     }
1401     else {
1402         $smtp_server = Koha::SMTP::Servers->get_default;
1403     }
1404
1405     if ( $username ) {
1406         $smtp_server->set(
1407             {
1408                 sasl_username => $username,
1409                 sasl_password => $password,
1410             }
1411         );
1412     }
1413
1414 # if initial message address was empty, coming here means that a to address was found and
1415 # queue should be updated; same if to address was overriden by Koha::Email->create
1416     _update_message_to_address( $message->{'message_id'}, $email->email->header('To') )
1417       if !$message->{to_address}
1418       || $message->{to_address} ne $email->email->header('To');
1419
1420     try {
1421         $email->send_or_die({ transport => $smtp_server->transport });
1422
1423         _set_message_status(
1424             {
1425                 message_id => $message->{'message_id'},
1426                 status     => 'sent',
1427                 delivery_note => ''
1428             }
1429         );
1430         return 1;
1431     }
1432     catch {
1433         _set_message_status(
1434             {
1435                 message_id => $message->{'message_id'},
1436                 status     => 'failed',
1437                 delivery_note => $Mail::Sendmail::error
1438             }
1439         );
1440         carp "$_";
1441         return;
1442     };
1443 }
1444
1445 sub _wrap_html {
1446     my ($content, $title) = @_;
1447
1448     my $css = C4::Context->preference("NoticeCSS") || '';
1449     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
1450     return <<EOS;
1451 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1452     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1453 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1454 <head>
1455 <title>$title</title>
1456 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1457 $css
1458 </head>
1459 <body>
1460 $content
1461 </body>
1462 </html>
1463 EOS
1464 }
1465
1466 sub _is_duplicate {
1467     my ( $message ) = @_;
1468     my $dbh = C4::Context->dbh;
1469     my $count = $dbh->selectrow_array(q|
1470         SELECT COUNT(*)
1471         FROM message_queue
1472         WHERE message_transport_type = ?
1473         AND borrowernumber = ?
1474         AND letter_code = ?
1475         AND CAST(updated_on AS date) = CAST(NOW() AS date)
1476         AND status="sent"
1477         AND content = ?
1478     |, {}, $message->{message_transport_type}, $message->{borrowernumber}, $message->{letter_code}, $message->{content} );
1479     return $count;
1480 }
1481
1482 sub _send_message_by_sms {
1483     my $message = shift or return;
1484     my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1485
1486     unless ( $patron and $patron->smsalertnumber ) {
1487         _set_message_status( { message_id => $message->{'message_id'},
1488                                status     => 'failed',
1489                                delivery_note => 'Missing SMS number',
1490                                error_code => 'MISSING_SMS' } );
1491         return;
1492     }
1493
1494     if ( _is_duplicate( $message ) ) {
1495         _set_message_status( { message_id => $message->{'message_id'},
1496                                status     => 'failed',
1497                                delivery_note => 'Message is duplicate',
1498                                error_code => 'DUPLICATE_MESSAGE' } );
1499         return;
1500     }
1501
1502     my $success = C4::SMS->send_sms( { destination => $patron->smsalertnumber,
1503                                        message     => $message->{'content'},
1504                                      } );
1505     _set_message_status( { message_id => $message->{'message_id'},
1506                            status     => ($success ? 'sent' : 'failed'),
1507                            delivery_note => ($success ? '' : 'No notes from SMS driver'),
1508                            error_code => 'NO_NOTES' } );
1509
1510     return $success;
1511 }
1512
1513 sub _update_message_to_address {
1514     my ($id, $to)= @_;
1515     my $dbh = C4::Context->dbh();
1516     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1517 }
1518
1519 sub _update_message_from_address {
1520     my ($message_id, $from_address) = @_;
1521     my $dbh = C4::Context->dbh();
1522     $dbh->do('UPDATE message_queue SET from_address = ? WHERE message_id = ?', undef, ($from_address, $message_id));
1523 }
1524
1525 sub _set_message_status {
1526     my $params = shift or return;
1527
1528     foreach my $required_parameter ( qw( message_id status ) ) {
1529         return unless exists $params->{ $required_parameter };
1530     }
1531
1532     my $dbh = C4::Context->dbh();
1533     my $statement = 'UPDATE message_queue SET status= ?, delivery_note= ? WHERE message_id = ?';
1534     my $sth = $dbh->prepare( $statement );
1535     my $result = $sth->execute( $params->{'status'},
1536                                 $params->{'delivery_note'} || '',
1537                                 $params->{'message_id'} );
1538     return $result;
1539 }
1540
1541 sub _process_tt {
1542     my ( $params ) = @_;
1543
1544     my $content = $params->{content};
1545     my $tables = $params->{tables};
1546     my $loops = $params->{loops};
1547     my $substitute = $params->{substitute} || {};
1548     my $lang = defined($params->{lang}) && $params->{lang} ne 'default' ? $params->{lang} : 'en';
1549     my ($theme, $activethemes);
1550
1551     my $htdocs = C4::Context->config('intrahtdocs');
1552     ($theme, $lang, $activethemes)= C4::Templates::activethemes( $htdocs, 'about.tt', 'intranet', $lang);
1553     my @includes;
1554     foreach (@$activethemes) {
1555         push @includes, "$htdocs/$_/$lang/includes";
1556         push @includes, "$htdocs/$_/en/includes" unless $lang eq 'en';
1557     }
1558
1559     my $use_template_cache = C4::Context->config('template_cache_dir') && defined $ENV{GATEWAY_INTERFACE};
1560     my $template           = Template->new(
1561         {
1562             EVAL_PERL    => 1,
1563             ABSOLUTE     => 1,
1564             PLUGIN_BASE  => 'Koha::Template::Plugin',
1565             COMPILE_EXT  => $use_template_cache ? '.ttc' : '',
1566             COMPILE_DIR  => $use_template_cache ? C4::Context->config('template_cache_dir') : '',
1567             INCLUDE_PATH => \@includes,
1568             FILTERS      => {},
1569             ENCODING     => 'UTF-8',
1570         }
1571     ) or die Template->error();
1572
1573     my $tt_params = { %{ _get_tt_params( $tables ) }, %{ _get_tt_params( $loops, 'is_a_loop' ) }, %$substitute };
1574
1575     $content = add_tt_filters( $content );
1576     $content = qq|[% USE KohaDates %][% USE Remove_MARC_punctuation %]$content|;
1577
1578     my $output;
1579     $template->process( \$content, $tt_params, \$output ) || croak "ERROR PROCESSING TEMPLATE: " . $template->error();
1580
1581     return $output;
1582 }
1583
1584 sub _get_tt_params {
1585     my ($tables, $is_a_loop) = @_;
1586
1587     my $params;
1588     $is_a_loop ||= 0;
1589
1590     my $config = {
1591         article_requests => {
1592             module   => 'Koha::ArticleRequests',
1593             singular => 'article_request',
1594             plural   => 'article_requests',
1595             pk       => 'id',
1596         },
1597         aqbasket => {
1598             module   => 'Koha::Acquisition::Baskets',
1599             singular => 'basket',
1600             plural   => 'baskets',
1601             pk       => 'basketno',
1602         },
1603         biblio => {
1604             module   => 'Koha::Biblios',
1605             singular => 'biblio',
1606             plural   => 'biblios',
1607             pk       => 'biblionumber',
1608         },
1609         biblioitems => {
1610             module   => 'Koha::Biblioitems',
1611             singular => 'biblioitem',
1612             plural   => 'biblioitems',
1613             pk       => 'biblioitemnumber',
1614         },
1615         borrowers => {
1616             module   => 'Koha::Patrons',
1617             singular => 'borrower',
1618             plural   => 'borrowers',
1619             pk       => 'borrowernumber',
1620         },
1621         branches => {
1622             module   => 'Koha::Libraries',
1623             singular => 'branch',
1624             plural   => 'branches',
1625             pk       => 'branchcode',
1626         },
1627         credits => {
1628             module => 'Koha::Account::Lines',
1629             singular => 'credit',
1630             plural => 'credits',
1631             pk => 'accountlines_id',
1632         },
1633         debits => {
1634             module => 'Koha::Account::Lines',
1635             singular => 'debit',
1636             plural => 'debits',
1637             pk => 'accountlines_id',
1638         },
1639         items => {
1640             module   => 'Koha::Items',
1641             singular => 'item',
1642             plural   => 'items',
1643             pk       => 'itemnumber',
1644         },
1645         opac_news => {
1646             module   => 'Koha::News',
1647             singular => 'news',
1648             plural   => 'news',
1649             pk       => 'idnew',
1650         },
1651         aqorders => {
1652             module   => 'Koha::Acquisition::Orders',
1653             singular => 'order',
1654             plural   => 'orders',
1655             pk       => 'ordernumber',
1656         },
1657         reserves => {
1658             module   => 'Koha::Holds',
1659             singular => 'hold',
1660             plural   => 'holds',
1661             pk       => 'reserve_id',
1662         },
1663         serial => {
1664             module   => 'Koha::Serials',
1665             singular => 'serial',
1666             plural   => 'serials',
1667             pk       => 'serialid',
1668         },
1669         subscription => {
1670             module   => 'Koha::Subscriptions',
1671             singular => 'subscription',
1672             plural   => 'subscriptions',
1673             pk       => 'subscriptionid',
1674         },
1675         suggestions => {
1676             module   => 'Koha::Suggestions',
1677             singular => 'suggestion',
1678             plural   => 'suggestions',
1679             pk       => 'suggestionid',
1680         },
1681         issues => {
1682             module   => 'Koha::Checkouts',
1683             singular => 'checkout',
1684             plural   => 'checkouts',
1685             fk       => 'itemnumber',
1686         },
1687         old_issues => {
1688             module   => 'Koha::Old::Checkouts',
1689             singular => 'old_checkout',
1690             plural   => 'old_checkouts',
1691             fk       => 'itemnumber',
1692         },
1693         overdues => {
1694             module   => 'Koha::Checkouts',
1695             singular => 'overdue',
1696             plural   => 'overdues',
1697             fk       => 'itemnumber',
1698         },
1699         borrower_modifications => {
1700             module   => 'Koha::Patron::Modifications',
1701             singular => 'patron_modification',
1702             plural   => 'patron_modifications',
1703             fk       => 'verification_token',
1704         },
1705         illrequests => {
1706             module   => 'Koha::Illrequests',
1707             singular => 'illrequest',
1708             plural   => 'illrequests',
1709             pk       => 'illrequest_id'
1710         }
1711     };
1712
1713     foreach my $table ( keys %$tables ) {
1714         next unless $config->{$table};
1715
1716         my $ref = ref( $tables->{$table} ) || q{};
1717         my $module = $config->{$table}->{module};
1718
1719         if ( can_load( modules => { $module => undef } ) ) {
1720             my $pk = $config->{$table}->{pk};
1721             my $fk = $config->{$table}->{fk};
1722
1723             if ( $is_a_loop ) {
1724                 my $values = $tables->{$table} || [];
1725                 unless ( ref( $values ) eq 'ARRAY' ) {
1726                     croak "ERROR processing table $table. Wrong API call.";
1727                 }
1728                 my $key = $pk ? $pk : $fk;
1729                 # $key does not come from user input
1730                 my $objects = $module->search(
1731                     { $key => $values },
1732                     {
1733                             # We want to retrieve the data in the same order
1734                             # FIXME MySQLism
1735                             # field is a MySQLism, but they are no other way to do it
1736                             # To be generic we could do it in perl, but we will need to fetch
1737                             # all the data then order them
1738                         @$values ? ( order_by => \[ "field($key, " . join( ', ', @$values ) . ")" ] ) : ()
1739                     }
1740                 );
1741                 $params->{ $config->{$table}->{plural} } = $objects;
1742             }
1743             elsif ( $ref eq q{} || $ref eq 'HASH' ) {
1744                 my $id = ref $ref eq 'HASH' ? $tables->{$table}->{$pk} : $tables->{$table};
1745                 my $object;
1746                 if ( $fk ) { # Using a foreign key for lookup
1747                     if ( ref( $fk ) eq 'ARRAY' ) { # Foreign key is multi-column
1748                         my $search;
1749                         foreach my $key ( @$fk ) {
1750                             $search->{$key} = $id->{$key};
1751                         }
1752                         $object = $module->search( $search )->last();
1753                     } else { # Foreign key is single column
1754                         $object = $module->search( { $fk => $id } )->last();
1755                     }
1756                 } else { # using the table's primary key for lookup
1757                     $object = $module->find($id);
1758                 }
1759                 $params->{ $config->{$table}->{singular} } = $object;
1760             }
1761             else {    # $ref eq 'ARRAY'
1762                 my $object;
1763                 if ( @{ $tables->{$table} } == 1 ) {    # Param is a single key
1764                     $object = $module->search( { $pk => $tables->{$table} } )->last();
1765                 }
1766                 else {                                  # Params are mutliple foreign keys
1767                     croak "Multiple foreign keys (table $table) should be passed using an hashref";
1768                 }
1769                 $params->{ $config->{$table}->{singular} } = $object;
1770             }
1771         }
1772         else {
1773             croak "ERROR LOADING MODULE $module: $Module::Load::Conditional::ERROR";
1774         }
1775     }
1776
1777     $params->{today} = output_pref({ dt => dt_from_string, dateformat => 'iso' });
1778
1779     return $params;
1780 }
1781
1782 =head3 add_tt_filters
1783
1784 $content = add_tt_filters( $content );
1785
1786 Add TT filters to some specific fields if needed.
1787
1788 For now we only add the Remove_MARC_punctuation TT filter to biblio and biblioitem fields
1789
1790 =cut
1791
1792 sub add_tt_filters {
1793     my ( $content ) = @_;
1794     $content =~ s|\[%\s*biblio\.(.*?)\s*%\]|[% biblio.$1 \| \$Remove_MARC_punctuation %]|gxms;
1795     $content =~ s|\[%\s*biblioitem\.(.*?)\s*%\]|[% biblioitem.$1 \| \$Remove_MARC_punctuation %]|gxms;
1796     return $content;
1797 }
1798
1799 =head2 get_item_content
1800
1801     my $item = Koha::Items->find(...)->unblessed;
1802     my @item_content_fields = qw( date_due title barcode author itemnumber );
1803     my $item_content = C4::Letters::get_item_content({
1804                              item => $item,
1805                              item_content_fields => \@item_content_fields
1806                        });
1807
1808 This function generates a tab-separated list of values for the passed item. Dates
1809 are formatted following the current setup.
1810
1811 =cut
1812
1813 sub get_item_content {
1814     my ( $params ) = @_;
1815     my $item = $params->{item};
1816     my $dateonly = $params->{dateonly} || 0;
1817     my $item_content_fields = $params->{item_content_fields} || [];
1818
1819     return unless $item;
1820
1821     my @item_info = map {
1822         $_ =~ /^date|date$/
1823           ? eval {
1824             output_pref(
1825                 { dt => dt_from_string( $item->{$_} ), dateonly => $dateonly } );
1826           }
1827           : $item->{$_}
1828           || ''
1829     } @$item_content_fields;
1830     return join( "\t", @item_info ) . "\n";
1831 }
1832
1833 1;
1834 __END__