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 DATETIME),       ?,          ?,            ?,           ?,              ? )
 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                                    error_code => 'INVALID_BORNUMBER' } );
1340             return;
1341         }
1342         $to_address = $patron->notice_email_address;
1343         unless ($to_address) {
1344             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
1345             # warning too verbose for this more common case?
1346             _set_message_status( { message_id => $message->{'message_id'},
1347                                    status     => 'failed',
1348                                    delivery_note => 'Unable to find an email address for this borrower',
1349                                    error_code => 'NO_EMAIL' } );
1350             return;
1351         }
1352     }
1353
1354     my $subject = $message->{'subject'};
1355
1356     my $content = $message->{'content'};
1357     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
1358     my $is_html = $content_type =~ m/html/io;
1359
1360     my $branch_email = undef;
1361     my $branch_replyto = undef;
1362     my $branch_returnpath = undef;
1363     my $library;
1364
1365     if ($patron) {
1366         $library           = $patron->library;
1367         $branch_email      = $library->branchemail;
1368         $branch_replyto    = $library->branchreplyto;
1369         $branch_returnpath = $library->branchreturnpath;
1370     }
1371
1372     my $email = Koha::Email->create(
1373         {
1374             to => $to_address,
1375             (
1376                 C4::Context->preference('NoticeBcc')
1377                 ? ( bcc => C4::Context->preference('NoticeBcc') )
1378                 : ()
1379             ),
1380             from     => $message->{'from_address'}  || $branch_email,
1381             reply_to => $message->{'reply_address'} || $branch_replyto,
1382             sender   => $branch_returnpath,
1383             subject  => "" . $message->{subject}
1384         }
1385     );
1386
1387     if ( $is_html ) {
1388         $email->html_body(
1389             _wrap_html( $content, $subject )
1390         );
1391     }
1392     else {
1393         $email->text_body( $content );
1394     }
1395
1396     my $smtp_server;
1397     if ( $library ) {
1398         $smtp_server = $library->smtp_server;
1399     }
1400     else {
1401         $smtp_server = Koha::SMTP::Servers->get_default;
1402     }
1403
1404     if ( $username ) {
1405         $smtp_server->set(
1406             {
1407                 sasl_username => $username,
1408                 sasl_password => $password,
1409             }
1410         );
1411     }
1412
1413 # if initial message address was empty, coming here means that a to address was found and
1414 # queue should be updated; same if to address was overriden by Koha::Email->create
1415     _update_message_to_address( $message->{'message_id'}, $email->email->header('To') )
1416       if !$message->{to_address}
1417       || $message->{to_address} ne $email->email->header('To');
1418
1419     try {
1420         $email->send_or_die({ transport => $smtp_server->transport });
1421
1422         _set_message_status(
1423             {
1424                 message_id => $message->{'message_id'},
1425                 status     => 'sent',
1426                 delivery_note => ''
1427             }
1428         );
1429         return 1;
1430     }
1431     catch {
1432         _set_message_status(
1433             {
1434                 message_id => $message->{'message_id'},
1435                 status     => 'failed',
1436                 delivery_note => $Mail::Sendmail::error
1437             }
1438         );
1439         carp "$_";
1440         return;
1441     };
1442 }
1443
1444 sub _wrap_html {
1445     my ($content, $title) = @_;
1446
1447     my $css = C4::Context->preference("NoticeCSS") || '';
1448     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
1449     return <<EOS;
1450 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1451     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1452 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1453 <head>
1454 <title>$title</title>
1455 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1456 $css
1457 </head>
1458 <body>
1459 $content
1460 </body>
1461 </html>
1462 EOS
1463 }
1464
1465 sub _is_duplicate {
1466     my ( $message ) = @_;
1467     my $dbh = C4::Context->dbh;
1468     my $count = $dbh->selectrow_array(q|
1469         SELECT COUNT(*)
1470         FROM message_queue
1471         WHERE message_transport_type = ?
1472         AND borrowernumber = ?
1473         AND letter_code = ?
1474         AND CAST(updated_on AS date) = CAST(NOW() AS date)
1475         AND status="sent"
1476         AND content = ?
1477     |, {}, $message->{message_transport_type}, $message->{borrowernumber}, $message->{letter_code}, $message->{content} );
1478     return $count;
1479 }
1480
1481 sub _send_message_by_sms {
1482     my $message = shift or return;
1483     my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1484
1485     unless ( $patron and $patron->smsalertnumber ) {
1486         _set_message_status( { message_id => $message->{'message_id'},
1487                                status     => 'failed',
1488                                delivery_note => 'Missing SMS number',
1489                                error_code => 'MISSING_SMS' } );
1490         return;
1491     }
1492
1493     if ( _is_duplicate( $message ) ) {
1494         _set_message_status( { message_id => $message->{'message_id'},
1495                                status     => 'failed',
1496                                delivery_note => 'Message is duplicate',
1497                                error_code => 'DUPLICATE_MESSAGE' } );
1498         return;
1499     }
1500
1501     my $success = C4::SMS->send_sms( { destination => $patron->smsalertnumber,
1502                                        message     => $message->{'content'},
1503                                      } );
1504     _set_message_status( { message_id => $message->{'message_id'},
1505                            status     => ($success ? 'sent' : 'failed'),
1506                            delivery_note => ($success ? '' : 'No notes from SMS driver'),
1507                            error_code => 'NO_NOTES' } );
1508
1509     return $success;
1510 }
1511
1512 sub _update_message_to_address {
1513     my ($id, $to)= @_;
1514     my $dbh = C4::Context->dbh();
1515     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1516 }
1517
1518 sub _update_message_from_address {
1519     my ($message_id, $from_address) = @_;
1520     my $dbh = C4::Context->dbh();
1521     $dbh->do('UPDATE message_queue SET from_address = ? WHERE message_id = ?', undef, ($from_address, $message_id));
1522 }
1523
1524 sub _set_message_status {
1525     my $params = shift or return;
1526
1527     foreach my $required_parameter ( qw( message_id status ) ) {
1528         return unless exists $params->{ $required_parameter };
1529     }
1530
1531     my $dbh = C4::Context->dbh();
1532     my $statement = 'UPDATE message_queue SET status= ?, delivery_note= ? WHERE message_id = ?';
1533     my $sth = $dbh->prepare( $statement );
1534     my $result = $sth->execute( $params->{'status'},
1535                                 $params->{'delivery_note'} || '',
1536                                 $params->{'message_id'} );
1537     return $result;
1538 }
1539
1540 sub _process_tt {
1541     my ( $params ) = @_;
1542
1543     my $content = $params->{content};
1544     my $tables = $params->{tables};
1545     my $loops = $params->{loops};
1546     my $substitute = $params->{substitute} || {};
1547     my $lang = defined($params->{lang}) && $params->{lang} ne 'default' ? $params->{lang} : 'en';
1548     my ($theme, $activethemes);
1549
1550     my $htdocs = C4::Context->config('intrahtdocs');
1551     ($theme, $lang, $activethemes)= C4::Templates::activethemes( $htdocs, 'about.tt', 'intranet', $lang);
1552     my @includes;
1553     foreach (@$activethemes) {
1554         push @includes, "$htdocs/$_/$lang/includes";
1555         push @includes, "$htdocs/$_/en/includes" unless $lang eq 'en';
1556     }
1557
1558     my $use_template_cache = C4::Context->config('template_cache_dir') && defined $ENV{GATEWAY_INTERFACE};
1559     my $template           = Template->new(
1560         {
1561             EVAL_PERL    => 1,
1562             ABSOLUTE     => 1,
1563             PLUGIN_BASE  => 'Koha::Template::Plugin',
1564             COMPILE_EXT  => $use_template_cache ? '.ttc' : '',
1565             COMPILE_DIR  => $use_template_cache ? C4::Context->config('template_cache_dir') : '',
1566             INCLUDE_PATH => \@includes,
1567             FILTERS      => {},
1568             ENCODING     => 'UTF-8',
1569         }
1570     ) or die Template->error();
1571
1572     my $tt_params = { %{ _get_tt_params( $tables ) }, %{ _get_tt_params( $loops, 'is_a_loop' ) }, %$substitute };
1573
1574     $content = add_tt_filters( $content );
1575     $content = qq|[% USE KohaDates %][% USE Remove_MARC_punctuation %]$content|;
1576
1577     my $output;
1578     $template->process( \$content, $tt_params, \$output ) || croak "ERROR PROCESSING TEMPLATE: " . $template->error();
1579
1580     return $output;
1581 }
1582
1583 sub _get_tt_params {
1584     my ($tables, $is_a_loop) = @_;
1585
1586     my $params;
1587     $is_a_loop ||= 0;
1588
1589     my $config = {
1590         article_requests => {
1591             module   => 'Koha::ArticleRequests',
1592             singular => 'article_request',
1593             plural   => 'article_requests',
1594             pk       => 'id',
1595         },
1596         aqbasket => {
1597             module   => 'Koha::Acquisition::Baskets',
1598             singular => 'basket',
1599             plural   => 'baskets',
1600             pk       => 'basketno',
1601         },
1602         biblio => {
1603             module   => 'Koha::Biblios',
1604             singular => 'biblio',
1605             plural   => 'biblios',
1606             pk       => 'biblionumber',
1607         },
1608         biblioitems => {
1609             module   => 'Koha::Biblioitems',
1610             singular => 'biblioitem',
1611             plural   => 'biblioitems',
1612             pk       => 'biblioitemnumber',
1613         },
1614         borrowers => {
1615             module   => 'Koha::Patrons',
1616             singular => 'borrower',
1617             plural   => 'borrowers',
1618             pk       => 'borrowernumber',
1619         },
1620         branches => {
1621             module   => 'Koha::Libraries',
1622             singular => 'branch',
1623             plural   => 'branches',
1624             pk       => 'branchcode',
1625         },
1626         credits => {
1627             module => 'Koha::Account::Lines',
1628             singular => 'credit',
1629             plural => 'credits',
1630             pk => 'accountlines_id',
1631         },
1632         debits => {
1633             module => 'Koha::Account::Lines',
1634             singular => 'debit',
1635             plural => 'debits',
1636             pk => 'accountlines_id',
1637         },
1638         items => {
1639             module   => 'Koha::Items',
1640             singular => 'item',
1641             plural   => 'items',
1642             pk       => 'itemnumber',
1643         },
1644         opac_news => {
1645             module   => 'Koha::News',
1646             singular => 'news',
1647             plural   => 'news',
1648             pk       => 'idnew',
1649         },
1650         aqorders => {
1651             module   => 'Koha::Acquisition::Orders',
1652             singular => 'order',
1653             plural   => 'orders',
1654             pk       => 'ordernumber',
1655         },
1656         reserves => {
1657             module   => 'Koha::Holds',
1658             singular => 'hold',
1659             plural   => 'holds',
1660             pk       => 'reserve_id',
1661         },
1662         serial => {
1663             module   => 'Koha::Serials',
1664             singular => 'serial',
1665             plural   => 'serials',
1666             pk       => 'serialid',
1667         },
1668         subscription => {
1669             module   => 'Koha::Subscriptions',
1670             singular => 'subscription',
1671             plural   => 'subscriptions',
1672             pk       => 'subscriptionid',
1673         },
1674         suggestions => {
1675             module   => 'Koha::Suggestions',
1676             singular => 'suggestion',
1677             plural   => 'suggestions',
1678             pk       => 'suggestionid',
1679         },
1680         issues => {
1681             module   => 'Koha::Checkouts',
1682             singular => 'checkout',
1683             plural   => 'checkouts',
1684             fk       => 'itemnumber',
1685         },
1686         old_issues => {
1687             module   => 'Koha::Old::Checkouts',
1688             singular => 'old_checkout',
1689             plural   => 'old_checkouts',
1690             fk       => 'itemnumber',
1691         },
1692         overdues => {
1693             module   => 'Koha::Checkouts',
1694             singular => 'overdue',
1695             plural   => 'overdues',
1696             fk       => 'itemnumber',
1697         },
1698         borrower_modifications => {
1699             module   => 'Koha::Patron::Modifications',
1700             singular => 'patron_modification',
1701             plural   => 'patron_modifications',
1702             fk       => 'verification_token',
1703         },
1704         illrequests => {
1705             module   => 'Koha::Illrequests',
1706             singular => 'illrequest',
1707             plural   => 'illrequests',
1708             pk       => 'illrequest_id'
1709         }
1710     };
1711
1712     foreach my $table ( keys %$tables ) {
1713         next unless $config->{$table};
1714
1715         my $ref = ref( $tables->{$table} ) || q{};
1716         my $module = $config->{$table}->{module};
1717
1718         if ( can_load( modules => { $module => undef } ) ) {
1719             my $pk = $config->{$table}->{pk};
1720             my $fk = $config->{$table}->{fk};
1721
1722             if ( $is_a_loop ) {
1723                 my $values = $tables->{$table} || [];
1724                 unless ( ref( $values ) eq 'ARRAY' ) {
1725                     croak "ERROR processing table $table. Wrong API call.";
1726                 }
1727                 my $key = $pk ? $pk : $fk;
1728                 # $key does not come from user input
1729                 my $objects = $module->search(
1730                     { $key => $values },
1731                     {
1732                             # We want to retrieve the data in the same order
1733                             # FIXME MySQLism
1734                             # field is a MySQLism, but they are no other way to do it
1735                             # To be generic we could do it in perl, but we will need to fetch
1736                             # all the data then order them
1737                         @$values ? ( order_by => \[ "field($key, " . join( ', ', @$values ) . ")" ] ) : ()
1738                     }
1739                 );
1740                 $params->{ $config->{$table}->{plural} } = $objects;
1741             }
1742             elsif ( $ref eq q{} || $ref eq 'HASH' ) {
1743                 my $id = ref $ref eq 'HASH' ? $tables->{$table}->{$pk} : $tables->{$table};
1744                 my $object;
1745                 if ( $fk ) { # Using a foreign key for lookup
1746                     if ( ref( $fk ) eq 'ARRAY' ) { # Foreign key is multi-column
1747                         my $search;
1748                         foreach my $key ( @$fk ) {
1749                             $search->{$key} = $id->{$key};
1750                         }
1751                         $object = $module->search( $search )->last();
1752                     } else { # Foreign key is single column
1753                         $object = $module->search( { $fk => $id } )->last();
1754                     }
1755                 } else { # using the table's primary key for lookup
1756                     $object = $module->find($id);
1757                 }
1758                 $params->{ $config->{$table}->{singular} } = $object;
1759             }
1760             else {    # $ref eq 'ARRAY'
1761                 my $object;
1762                 if ( @{ $tables->{$table} } == 1 ) {    # Param is a single key
1763                     $object = $module->search( { $pk => $tables->{$table} } )->last();
1764                 }
1765                 else {                                  # Params are mutliple foreign keys
1766                     croak "Multiple foreign keys (table $table) should be passed using an hashref";
1767                 }
1768                 $params->{ $config->{$table}->{singular} } = $object;
1769             }
1770         }
1771         else {
1772             croak "ERROR LOADING MODULE $module: $Module::Load::Conditional::ERROR";
1773         }
1774     }
1775
1776     $params->{today} = output_pref({ dt => dt_from_string, dateformat => 'iso' });
1777
1778     return $params;
1779 }
1780
1781 =head3 add_tt_filters
1782
1783 $content = add_tt_filters( $content );
1784
1785 Add TT filters to some specific fields if needed.
1786
1787 For now we only add the Remove_MARC_punctuation TT filter to biblio and biblioitem fields
1788
1789 =cut
1790
1791 sub add_tt_filters {
1792     my ( $content ) = @_;
1793     $content =~ s|\[%\s*biblio\.(.*?)\s*%\]|[% biblio.$1 \| \$Remove_MARC_punctuation %]|gxms;
1794     $content =~ s|\[%\s*biblioitem\.(.*?)\s*%\]|[% biblioitem.$1 \| \$Remove_MARC_punctuation %]|gxms;
1795     return $content;
1796 }
1797
1798 =head2 get_item_content
1799
1800     my $item = Koha::Items->find(...)->unblessed;
1801     my @item_content_fields = qw( date_due title barcode author itemnumber );
1802     my $item_content = C4::Letters::get_item_content({
1803                              item => $item,
1804                              item_content_fields => \@item_content_fields
1805                        });
1806
1807 This function generates a tab-separated list of values for the passed item. Dates
1808 are formatted following the current setup.
1809
1810 =cut
1811
1812 sub get_item_content {
1813     my ( $params ) = @_;
1814     my $item = $params->{item};
1815     my $dateonly = $params->{dateonly} || 0;
1816     my $item_content_fields = $params->{item_content_fields} || [];
1817
1818     return unless $item;
1819
1820     my @item_info = map {
1821         $_ =~ /^date|date$/
1822           ? eval {
1823             output_pref(
1824                 { dt => dt_from_string( $item->{$_} ), dateonly => $dateonly } );
1825           }
1826           : $item->{$_}
1827           || ''
1828     } @$item_content_fields;
1829     return join( "\t", @item_info ) . "\n";
1830 }
1831
1832 1;
1833 __END__