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 Parameters
 939 * letter - required; A letter hashref as returned from GetPreparedLetter
 940 * message_transport_type - required; One of the available mtts
 941 * borrowernumber - optional if 'to_address' is passed; The borrowernumber of the patron we enqueuing the notice for
 942 * to_address - optional if 'borrowernumber' is passed; The destination email address for the notice (defaults to patron->notice_email_address)
 943 * from_address - optional; The from address for the notice, defaults to patron->library->from_email_address
 944 * reply_address - optional; The reply address for the notice, defaults to patron->library->reply_to
 945
 946 =cut
 947
 948 sub EnqueueLetter {
 949     my $params = shift or return;
 950
 951     return unless exists $params->{'letter'};
 952 #   return unless exists $params->{'borrowernumber'};
 953     return unless exists $params->{'message_transport_type'};
 954
 955     my $content = $params->{letter}->{content};
 956     $content =~ s/\s+//g if(defined $content);
 957     if ( not defined $content or $content eq '' ) {
 958         warn "Trying to add an empty message to the message queue" if $debug;
 959         return;
 960     }
 961
 962     # If we have any attachments we should encode then into the body.
 963     if ( $params->{'attachments'} ) {
 964         $params->{'letter'} = _add_attachments(
 965             {   letter      => $params->{'letter'},
 966                 attachments => $params->{'attachments'},
 967                 message     => MIME::Lite->new( Type => 'multipart/mixed' ),
 968             }
 969         );
 970     }
 971
 972     my $dbh       = C4::Context->dbh();
 973     my $statement = << 'ENDSQL';
 974 INSERT INTO message_queue
 975 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, reply_address, content_type, delivery_note )
 976 VALUES
 977 ( ?,              ?,       ?,       ?,        ?,           ?,                      ?,      CAST(NOW() AS DATETIME),       ?,          ?,            ?,           ?,              ? )
 978 ENDSQL
 979
 980     my $sth    = $dbh->prepare($statement);
 981     my $result = $sth->execute(
 982         $params->{'borrowernumber'},              # borrowernumber
 983         $params->{'letter'}->{'title'},           # subject
 984         $params->{'letter'}->{'content'},         # content
 985         $params->{'letter'}->{'metadata'} || '',  # metadata
 986         $params->{'letter'}->{'code'}     || '',  # letter_code
 987         $params->{'message_transport_type'},      # message_transport_type
 988         'pending',                                # status
 989         $params->{'to_address'},                  # to_address
 990         $params->{'from_address'},                # from_address
 991         $params->{'reply_address'},               # reply_address
 992         $params->{'letter'}->{'content-type'},    # content_type
 993         $params->{'delivery_note'}        || '',  # delivery_note
 994     );
 995     return $dbh->last_insert_id(undef,undef,'message_queue', undef);
 996 }
 997
 998 =head2 SendQueuedMessages ([$hashref])
 999
1000     my $sent = SendQueuedMessages({
1001         letter_code => $letter_code,
1002         borrowernumber => $who_letter_is_for,
1003         limit => 50,
1004         verbose => 1,
1005         type => 'sms',
1006     });
1007
1008 Sends all of the 'pending' items in the message queue, unless
1009 parameters are passed.
1010
1011 The letter_code, borrowernumber and limit parameters are used
1012 to build a parameter set for _get_unsent_messages, thus limiting
1013 which pending messages will be processed. They are all optional.
1014
1015 The verbose parameter can be used to generate debugging output.
1016 It is also optional.
1017
1018 Returns number of messages sent.
1019
1020 =cut
1021
1022 sub SendQueuedMessages {
1023     my $params = shift;
1024
1025     my $which_unsent_messages  = {
1026         'message_id'     => $params->{'message_id'},
1027         'limit'          => $params->{'limit'} // 0,
1028         'borrowernumber' => $params->{'borrowernumber'} // q{},
1029         'letter_code'    => $params->{'letter_code'} // q{},
1030         'type'           => $params->{'type'} // q{},
1031     };
1032     my $unsent_messages = _get_unsent_messages( $which_unsent_messages );
1033     MESSAGE: foreach my $message ( @$unsent_messages ) {
1034         my $message_object = Koha::Notice::Messages->find( $message->{message_id} );
1035         # If this fails the database is unwritable and we won't manage to send a message that continues to be marked 'pending'
1036         $message_object->make_column_dirty('status');
1037         return unless $message_object->store;
1038
1039         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
1040         warn sprintf( 'sending %s message to patron: %s',
1041                       $message->{'message_transport_type'},
1042                       $message->{'borrowernumber'} || 'Admin' )
1043           if $params->{'verbose'} or $debug;
1044         # This is just begging for subclassing
1045         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
1046         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
1047             _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
1048         }
1049         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
1050             if ( C4::Context->preference('SMSSendDriver') eq 'Email' ) {
1051                 my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1052                 my $sms_provider = Koha::SMS::Providers->find( $patron->sms_provider_id );
1053                 unless ( $sms_provider ) {
1054                     warn sprintf( "Patron %s has no sms provider id set!", $message->{'borrowernumber'} ) if $params->{'verbose'} or $debug;
1055                     _set_message_status( { message_id => $message->{'message_id'}, status => 'failed' } );
1056                     next MESSAGE;
1057                 }
1058                 unless ( $patron->smsalertnumber ) {
1059                     _set_message_status( { message_id => $message->{'message_id'}, status => 'failed' } );
1060                     warn sprintf( "No smsalertnumber found for patron %s!", $message->{'borrowernumber'} ) if $params->{'verbose'} or $debug;
1061                     next MESSAGE;
1062                 }
1063                 $message->{to_address}  = $patron->smsalertnumber; #Sometime this is set to email - sms should always use smsalertnumber
1064                 $message->{to_address} .= '@' . $sms_provider->domain();
1065
1066                 # Check for possible from_address override
1067                 my $from_address = C4::Context->preference('EmailSMSSendDriverFromAddress');
1068                 if ($from_address && $message->{from_address} ne $from_address) {
1069                     $message->{from_address} = $from_address;
1070                     _update_message_from_address($message->{'message_id'}, $message->{from_address});
1071                 }
1072
1073                 _update_message_to_address($message->{'message_id'}, $message->{to_address});
1074                 _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
1075             } else {
1076                 _send_message_by_sms( $message );
1077             }
1078         }
1079     }
1080     return scalar( @$unsent_messages );
1081 }
1082
1083 =head2 GetRSSMessages
1084
1085   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
1086
1087 returns a listref of all queued RSS messages for a particular person.
1088
1089 =cut
1090
1091 sub GetRSSMessages {
1092     my $params = shift;
1093
1094     return unless $params;
1095     return unless ref $params;
1096     return unless $params->{'borrowernumber'};
1097
1098     return _get_unsent_messages( { message_transport_type => 'rss',
1099                                    limit                  => $params->{'limit'},
1100                                    borrowernumber         => $params->{'borrowernumber'}, } );
1101 }
1102
1103 =head2 GetPrintMessages
1104
1105   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
1106
1107 Returns a arrayref of all queued print messages (optionally, for a particular
1108 person).
1109
1110 =cut
1111
1112 sub GetPrintMessages {
1113     my $params = shift || {};
1114
1115     return _get_unsent_messages( { message_transport_type => 'print',
1116                                    borrowernumber         => $params->{'borrowernumber'},
1117                                  } );
1118 }
1119
1120 =head2 GetQueuedMessages ([$hashref])
1121
1122   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
1123
1124 Fetches a list of messages from the message queue optionally filtered by borrowernumber
1125 and limited to specified limit.
1126
1127 Return is an arrayref of hashes, each has represents a message in the message queue.
1128
1129 =cut
1130
1131 sub GetQueuedMessages {
1132     my $params = shift;
1133
1134     my $dbh = C4::Context->dbh();
1135     my $statement = << 'ENDSQL';
1136 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued, updated_on, delivery_note
1137 FROM message_queue
1138 ENDSQL
1139
1140     my @query_params;
1141     my @whereclauses;
1142     if ( exists $params->{'borrowernumber'} ) {
1143         push @whereclauses, ' borrowernumber = ? ';
1144         push @query_params, $params->{'borrowernumber'};
1145     }
1146
1147     if ( @whereclauses ) {
1148         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
1149     }
1150
1151     if ( defined $params->{'limit'} ) {
1152         $statement .= ' LIMIT ? ';
1153         push @query_params, $params->{'limit'};
1154     }
1155
1156     my $sth = $dbh->prepare( $statement );
1157     my $result = $sth->execute( @query_params );
1158     return $sth->fetchall_arrayref({});
1159 }
1160
1161 =head2 GetMessageTransportTypes
1162
1163   my @mtt = GetMessageTransportTypes();
1164
1165   returns an arrayref of transport types
1166
1167 =cut
1168
1169 sub GetMessageTransportTypes {
1170     my $dbh = C4::Context->dbh();
1171     my $mtts = $dbh->selectcol_arrayref("
1172         SELECT message_transport_type
1173         FROM message_transport_types
1174         ORDER BY message_transport_type
1175     ");
1176     return $mtts;
1177 }
1178
1179 =head2 GetMessage
1180
1181     my $message = C4::Letters::Message($message_id);
1182
1183 =cut
1184
1185 sub GetMessage {
1186     my ( $message_id ) = @_;
1187     return unless $message_id;
1188     my $dbh = C4::Context->dbh;
1189     return $dbh->selectrow_hashref(q|
1190         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
1191         FROM message_queue
1192         WHERE message_id = ?
1193     |, {}, $message_id );
1194 }
1195
1196 =head2 ResendMessage
1197
1198   Attempt to resend a message which has failed previously.
1199
1200   my $has_been_resent = C4::Letters::ResendMessage($message_id);
1201
1202   Updates the message to 'pending' status so that
1203   it will be resent later on.
1204
1205   returns 1 on success, 0 on failure, undef if no message was found
1206
1207 =cut
1208
1209 sub ResendMessage {
1210     my $message_id = shift;
1211     return unless $message_id;
1212
1213     my $message = GetMessage( $message_id );
1214     return unless $message;
1215     my $rv = 0;
1216     if ( $message->{status} ne 'pending' ) {
1217         $rv = C4::Letters::_set_message_status({
1218             message_id => $message_id,
1219             status => 'pending',
1220         });
1221         $rv = $rv > 0? 1: 0;
1222         # Clear destination email address to force address update
1223         _update_message_to_address( $message_id, undef ) if $rv &&
1224             $message->{message_transport_type} eq 'email';
1225     }
1226     return $rv;
1227 }
1228
1229 =head2 _add_attachements
1230
1231   named parameters:
1232   letter - the standard letter hashref
1233   attachments - listref of attachments. each attachment is a hashref of:
1234     type - the mime type, like 'text/plain'
1235     content - the actual attachment
1236     filename - the name of the attachment.
1237   message - a MIME::Lite object to attach these to.
1238
1239   returns your letter object, with the content updated.
1240
1241 =cut
1242
1243 sub _add_attachments {
1244     my $params = shift;
1245
1246     my $letter = $params->{'letter'};
1247     my $attachments = $params->{'attachments'};
1248     return $letter unless @$attachments;
1249     my $message = $params->{'message'};
1250
1251     # First, we have to put the body in as the first attachment
1252     $message->attach(
1253         Type => $letter->{'content-type'} || 'TEXT',
1254         Data => $letter->{'is_html'}
1255             ? _wrap_html($letter->{'content'}, $letter->{'title'})
1256             : $letter->{'content'},
1257     );
1258
1259     foreach my $attachment ( @$attachments ) {
1260         $message->attach(
1261             Type     => $attachment->{'type'},
1262             Data     => $attachment->{'content'},
1263             Filename => $attachment->{'filename'},
1264         );
1265     }
1266     # we're forcing list context here to get the header, not the count back from grep.
1267     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
1268     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
1269     $letter->{'content'} = $message->body_as_string;
1270
1271     return $letter;
1272
1273 }
1274
1275 =head2 _get_unsent_messages
1276
1277   This function's parameter hash reference takes the following
1278   optional named parameters:
1279    message_transport_type: method of message sending (e.g. email, sms, etc.)
1280    borrowernumber        : who the message is to be sent
1281    letter_code           : type of message being sent (e.g. PASSWORD_RESET)
1282    message_id            : the message_id of the message. In that case the sub will return only 1 result
1283    limit                 : maximum number of messages to send
1284
1285   This function returns an array of matching hash referenced rows from
1286   message_queue with some borrower information added.
1287
1288 =cut
1289
1290 sub _get_unsent_messages {
1291     my $params = shift;
1292
1293     my $dbh = C4::Context->dbh();
1294     my $statement = qq{
1295         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
1296         FROM message_queue mq
1297         LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
1298         WHERE status = ?
1299     };
1300
1301     my @query_params = ('pending');
1302     if ( ref $params ) {
1303         if ( $params->{'message_transport_type'} ) {
1304             $statement .= ' AND mq.message_transport_type = ? ';
1305             push @query_params, $params->{'message_transport_type'};
1306         }
1307         if ( $params->{'borrowernumber'} ) {
1308             $statement .= ' AND mq.borrowernumber = ? ';
1309             push @query_params, $params->{'borrowernumber'};
1310         }
1311         if ( $params->{'letter_code'} ) {
1312             $statement .= ' AND mq.letter_code = ? ';
1313             push @query_params, $params->{'letter_code'};
1314         }
1315         if ( $params->{'type'} ) {
1316             $statement .= ' AND message_transport_type = ? ';
1317             push @query_params, $params->{'type'};
1318         }
1319         if ( $params->{message_id} ) {
1320             $statement .= ' AND message_id = ?';
1321             push @query_params, $params->{message_id};
1322         }
1323         if ( $params->{'limit'} ) {
1324             $statement .= ' limit ? ';
1325             push @query_params, $params->{'limit'};
1326         }
1327     }
1328
1329     $debug and warn "_get_unsent_messages SQL: $statement";
1330     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
1331     my $sth = $dbh->prepare( $statement );
1332     my $result = $sth->execute( @query_params );
1333     return $sth->fetchall_arrayref({});
1334 }
1335
1336 sub _send_message_by_email {
1337     my $message = shift or return;
1338     my ($username, $password, $method) = @_;
1339
1340     my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1341     my $to_address = $message->{'to_address'};
1342     unless ($to_address) {
1343         unless ($patron) {
1344             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
1345             _set_message_status( { message_id => $message->{'message_id'},
1346                                    status     => 'failed',
1347                                    delivery_note => 'Invalid borrowernumber '.$message->{borrowernumber},
1348                                    error_code => 'INVALID_BORNUMBER' } );
1349             return;
1350         }
1351         $to_address = $patron->notice_email_address;
1352         unless ($to_address) {
1353             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
1354             # warning too verbose for this more common case?
1355             _set_message_status( { message_id => $message->{'message_id'},
1356                                    status     => 'failed',
1357                                    delivery_note => 'Unable to find an email address for this borrower',
1358                                    error_code => 'NO_EMAIL' } );
1359             return;
1360         }
1361     }
1362
1363     my $subject = $message->{'subject'};
1364
1365     my $content = $message->{'content'};
1366     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
1367     my $is_html = $content_type =~ m/html/io;
1368
1369     my $branch_email = undef;
1370     my $branch_replyto = undef;
1371     my $branch_returnpath = undef;
1372     my $library;
1373
1374     if ($patron) {
1375         $library           = $patron->library;
1376         $branch_email      = $library->from_email_address;
1377         $branch_replyto    = $library->branchreplyto;
1378         $branch_returnpath = $library->branchreturnpath;
1379     }
1380
1381     # NOTE: Patron may not be defined above so branch_email may be undefined still
1382     # so we need to fallback to KohaAdminEmailAddress as a last resort.
1383     my $from_address =
1384          $message->{'from_address'}
1385       || $branch_email
1386       || C4::Context->preference('KohaAdminEmailAddress');
1387     if( !$from_address ) {
1388         _set_message_status({
1389             message_id => $message->{'message_id'},
1390             status     => 'failed',
1391             delivery_note => 'No from address',
1392         });
1393         return;
1394     };
1395     my $email = Koha::Email->create(
1396         {
1397             to => $to_address,
1398             (
1399                 C4::Context->preference('NoticeBcc')
1400                 ? ( bcc => C4::Context->preference('NoticeBcc') )
1401                 : ()
1402             ),
1403             from     => $from_address,
1404             reply_to => $message->{'reply_address'} || $branch_replyto,
1405             sender   => $branch_returnpath,
1406             subject  => "" . $message->{subject}
1407         }
1408     );
1409
1410     if ( $is_html ) {
1411         $email->html_body(
1412             _wrap_html( $content, $subject )
1413         );
1414     }
1415     else {
1416         $email->text_body( $content );
1417     }
1418
1419     my $smtp_server;
1420     if ( $library ) {
1421         $smtp_server = $library->smtp_server;
1422     }
1423     else {
1424         $smtp_server = Koha::SMTP::Servers->get_default;
1425     }
1426
1427     if ( $username ) {
1428         $smtp_server->set(
1429             {
1430                 sasl_username => $username,
1431                 sasl_password => $password,
1432             }
1433         );
1434     }
1435
1436 # if initial message address was empty, coming here means that a to address was found and
1437 # queue should be updated; same if to address was overriden by Koha::Email->create
1438     _update_message_to_address( $message->{'message_id'}, $email->email->header('To') )
1439       if !$message->{to_address}
1440       || $message->{to_address} ne $email->email->header('To');
1441
1442     try {
1443         $email->send_or_die({ transport => $smtp_server->transport });
1444
1445         _set_message_status(
1446             {
1447                 message_id => $message->{'message_id'},
1448                 status     => 'sent',
1449                 delivery_note => ''
1450             }
1451         );
1452         return 1;
1453     }
1454     catch {
1455         _set_message_status(
1456             {
1457                 message_id => $message->{'message_id'},
1458                 status     => 'failed',
1459                 delivery_note => $Mail::Sendmail::error
1460             }
1461         );
1462         carp "$_";
1463         return;
1464     };
1465 }
1466
1467 sub _wrap_html {
1468     my ($content, $title) = @_;
1469
1470     my $css = C4::Context->preference("NoticeCSS") || '';
1471     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
1472     return <<EOS;
1473 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1474     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1475 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1476 <head>
1477 <title>$title</title>
1478 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1479 $css
1480 </head>
1481 <body>
1482 $content
1483 </body>
1484 </html>
1485 EOS
1486 }
1487
1488 sub _is_duplicate {
1489     my ( $message ) = @_;
1490     my $dbh = C4::Context->dbh;
1491     my $count = $dbh->selectrow_array(q|
1492         SELECT COUNT(*)
1493         FROM message_queue
1494         WHERE message_transport_type = ?
1495         AND borrowernumber = ?
1496         AND letter_code = ?
1497         AND CAST(updated_on AS date) = CAST(NOW() AS date)
1498         AND status="sent"
1499         AND content = ?
1500     |, {}, $message->{message_transport_type}, $message->{borrowernumber}, $message->{letter_code}, $message->{content} );
1501     return $count;
1502 }
1503
1504 sub _send_message_by_sms {
1505     my $message = shift or return;
1506     my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1507
1508     unless ( $patron and $patron->smsalertnumber ) {
1509         _set_message_status( { message_id => $message->{'message_id'},
1510                                status     => 'failed',
1511                                delivery_note => 'Missing SMS number',
1512                                error_code => 'MISSING_SMS' } );
1513         return;
1514     }
1515
1516     if ( _is_duplicate( $message ) ) {
1517         _set_message_status( { message_id => $message->{'message_id'},
1518                                status     => 'failed',
1519                                delivery_note => 'Message is duplicate',
1520                                error_code => 'DUPLICATE_MESSAGE' } );
1521         return;
1522     }
1523
1524     my $success = C4::SMS->send_sms( { destination => $patron->smsalertnumber,
1525                                        message     => $message->{'content'},
1526                                      } );
1527     _set_message_status( { message_id => $message->{'message_id'},
1528                            status     => ($success ? 'sent' : 'failed'),
1529                            delivery_note => ($success ? '' : 'No notes from SMS driver'),
1530                            error_code => 'NO_NOTES' } );
1531
1532     return $success;
1533 }
1534
1535 sub _update_message_to_address {
1536     my ($id, $to)= @_;
1537     my $dbh = C4::Context->dbh();
1538     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1539 }
1540
1541 sub _update_message_from_address {
1542     my ($message_id, $from_address) = @_;
1543     my $dbh = C4::Context->dbh();
1544     $dbh->do('UPDATE message_queue SET from_address = ? WHERE message_id = ?', undef, ($from_address, $message_id));
1545 }
1546
1547 sub _set_message_status {
1548     my $params = shift or return;
1549
1550     foreach my $required_parameter ( qw( message_id status ) ) {
1551         return unless exists $params->{ $required_parameter };
1552     }
1553
1554     my $dbh = C4::Context->dbh();
1555     my $statement = 'UPDATE message_queue SET status= ?, delivery_note= ? WHERE message_id = ?';
1556     my $sth = $dbh->prepare( $statement );
1557     my $result = $sth->execute( $params->{'status'},
1558                                 $params->{'delivery_note'} || '',
1559                                 $params->{'message_id'} );
1560     return $result;
1561 }
1562
1563 sub _process_tt {
1564     my ( $params ) = @_;
1565
1566     my $content = $params->{content};
1567     my $tables = $params->{tables};
1568     my $loops = $params->{loops};
1569     my $substitute = $params->{substitute} || {};
1570     my $lang = defined($params->{lang}) && $params->{lang} ne 'default' ? $params->{lang} : 'en';
1571     my ($theme, $availablethemes);
1572
1573     my $htdocs = C4::Context->config('intrahtdocs');
1574     ($theme, $lang, $availablethemes)= C4::Templates::availablethemes( $htdocs, 'about.tt', 'intranet', $lang);
1575     my @includes;
1576     foreach (@$availablethemes) {
1577         push @includes, "$htdocs/$_/$lang/includes";
1578         push @includes, "$htdocs/$_/en/includes" unless $lang eq 'en';
1579     }
1580
1581     my $use_template_cache = C4::Context->config('template_cache_dir') && defined $ENV{GATEWAY_INTERFACE};
1582     my $template           = Template->new(
1583         {
1584             EVAL_PERL    => 1,
1585             ABSOLUTE     => 1,
1586             PLUGIN_BASE  => 'Koha::Template::Plugin',
1587             COMPILE_EXT  => $use_template_cache ? '.ttc' : '',
1588             COMPILE_DIR  => $use_template_cache ? C4::Context->config('template_cache_dir') : '',
1589             INCLUDE_PATH => \@includes,
1590             FILTERS      => {},
1591             ENCODING     => 'UTF-8',
1592         }
1593     ) or die Template->error();
1594
1595     my $tt_params = { %{ _get_tt_params( $tables ) }, %{ _get_tt_params( $loops, 'is_a_loop' ) }, %$substitute };
1596
1597     $content = add_tt_filters( $content );
1598     $content = qq|[% USE KohaDates %][% USE Remove_MARC_punctuation %]$content|;
1599
1600     my $output;
1601     $template->process( \$content, $tt_params, \$output ) || croak "ERROR PROCESSING TEMPLATE: " . $template->error();
1602
1603     return $output;
1604 }
1605
1606 sub _get_tt_params {
1607     my ($tables, $is_a_loop) = @_;
1608
1609     my $params;
1610     $is_a_loop ||= 0;
1611
1612     my $config = {
1613         article_requests => {
1614             module   => 'Koha::ArticleRequests',
1615             singular => 'article_request',
1616             plural   => 'article_requests',
1617             pk       => 'id',
1618         },
1619         aqbasket => {
1620             module   => 'Koha::Acquisition::Baskets',
1621             singular => 'basket',
1622             plural   => 'baskets',
1623             pk       => 'basketno',
1624         },
1625         biblio => {
1626             module   => 'Koha::Biblios',
1627             singular => 'biblio',
1628             plural   => 'biblios',
1629             pk       => 'biblionumber',
1630         },
1631         biblioitems => {
1632             module   => 'Koha::Biblioitems',
1633             singular => 'biblioitem',
1634             plural   => 'biblioitems',
1635             pk       => 'biblioitemnumber',
1636         },
1637         borrowers => {
1638             module   => 'Koha::Patrons',
1639             singular => 'borrower',
1640             plural   => 'borrowers',
1641             pk       => 'borrowernumber',
1642         },
1643         branches => {
1644             module   => 'Koha::Libraries',
1645             singular => 'branch',
1646             plural   => 'branches',
1647             pk       => 'branchcode',
1648         },
1649         credits => {
1650             module => 'Koha::Account::Lines',
1651             singular => 'credit',
1652             plural => 'credits',
1653             pk => 'accountlines_id',
1654         },
1655         debits => {
1656             module => 'Koha::Account::Lines',
1657             singular => 'debit',
1658             plural => 'debits',
1659             pk => 'accountlines_id',
1660         },
1661         items => {
1662             module   => 'Koha::Items',
1663             singular => 'item',
1664             plural   => 'items',
1665             pk       => 'itemnumber',
1666         },
1667         opac_news => {
1668             module   => 'Koha::News',
1669             singular => 'news',
1670             plural   => 'news',
1671             pk       => 'idnew',
1672         },
1673         aqorders => {
1674             module   => 'Koha::Acquisition::Orders',
1675             singular => 'order',
1676             plural   => 'orders',
1677             pk       => 'ordernumber',
1678         },
1679         reserves => {
1680             module   => 'Koha::Holds',
1681             singular => 'hold',
1682             plural   => 'holds',
1683             pk       => 'reserve_id',
1684         },
1685         serial => {
1686             module   => 'Koha::Serials',
1687             singular => 'serial',
1688             plural   => 'serials',
1689             pk       => 'serialid',
1690         },
1691         subscription => {
1692             module   => 'Koha::Subscriptions',
1693             singular => 'subscription',
1694             plural   => 'subscriptions',
1695             pk       => 'subscriptionid',
1696         },
1697         suggestions => {
1698             module   => 'Koha::Suggestions',
1699             singular => 'suggestion',
1700             plural   => 'suggestions',
1701             pk       => 'suggestionid',
1702         },
1703         issues => {
1704             module   => 'Koha::Checkouts',
1705             singular => 'checkout',
1706             plural   => 'checkouts',
1707             fk       => 'itemnumber',
1708         },
1709         old_issues => {
1710             module   => 'Koha::Old::Checkouts',
1711             singular => 'old_checkout',
1712             plural   => 'old_checkouts',
1713             fk       => 'itemnumber',
1714         },
1715         overdues => {
1716             module   => 'Koha::Checkouts',
1717             singular => 'overdue',
1718             plural   => 'overdues',
1719             fk       => 'itemnumber',
1720         },
1721         borrower_modifications => {
1722             module   => 'Koha::Patron::Modifications',
1723             singular => 'patron_modification',
1724             plural   => 'patron_modifications',
1725             fk       => 'verification_token',
1726         },
1727         illrequests => {
1728             module   => 'Koha::Illrequests',
1729             singular => 'illrequest',
1730             plural   => 'illrequests',
1731             pk       => 'illrequest_id'
1732         }
1733     };
1734
1735     foreach my $table ( keys %$tables ) {
1736         next unless $config->{$table};
1737
1738         my $ref = ref( $tables->{$table} ) || q{};
1739         my $module = $config->{$table}->{module};
1740
1741         if ( can_load( modules => { $module => undef } ) ) {
1742             my $pk = $config->{$table}->{pk};
1743             my $fk = $config->{$table}->{fk};
1744
1745             if ( $is_a_loop ) {
1746                 my $values = $tables->{$table} || [];
1747                 unless ( ref( $values ) eq 'ARRAY' ) {
1748                     croak "ERROR processing table $table. Wrong API call.";
1749                 }
1750                 my $key = $pk ? $pk : $fk;
1751                 # $key does not come from user input
1752                 my $objects = $module->search(
1753                     { $key => $values },
1754                     {
1755                             # We want to retrieve the data in the same order
1756                             # FIXME MySQLism
1757                             # field is a MySQLism, but they are no other way to do it
1758                             # To be generic we could do it in perl, but we will need to fetch
1759                             # all the data then order them
1760                         @$values ? ( order_by => \[ "field($key, " . join( ', ', @$values ) . ")" ] ) : ()
1761                     }
1762                 );
1763                 $params->{ $config->{$table}->{plural} } = $objects;
1764             }
1765             elsif ( $ref eq q{} || $ref eq 'HASH' ) {
1766                 my $id = ref $ref eq 'HASH' ? $tables->{$table}->{$pk} : $tables->{$table};
1767                 my $object;
1768                 if ( $fk ) { # Using a foreign key for lookup
1769                     if ( ref( $fk ) eq 'ARRAY' ) { # Foreign key is multi-column
1770                         my $search;
1771                         foreach my $key ( @$fk ) {
1772                             $search->{$key} = $id->{$key};
1773                         }
1774                         $object = $module->search( $search )->last();
1775                     } else { # Foreign key is single column
1776                         $object = $module->search( { $fk => $id } )->last();
1777                     }
1778                 } else { # using the table's primary key for lookup
1779                     $object = $module->find($id);
1780                 }
1781                 $params->{ $config->{$table}->{singular} } = $object;
1782             }
1783             else {    # $ref eq 'ARRAY'
1784                 my $object;
1785                 if ( @{ $tables->{$table} } == 1 ) {    # Param is a single key
1786                     $object = $module->search( { $pk => $tables->{$table} } )->last();
1787                 }
1788                 else {                                  # Params are mutliple foreign keys
1789                     croak "Multiple foreign keys (table $table) should be passed using an hashref";
1790                 }
1791                 $params->{ $config->{$table}->{singular} } = $object;
1792             }
1793         }
1794         else {
1795             croak "ERROR LOADING MODULE $module: $Module::Load::Conditional::ERROR";
1796         }
1797     }
1798
1799     $params->{today} = output_pref({ dt => dt_from_string, dateformat => 'iso' });
1800
1801     return $params;
1802 }
1803
1804 =head3 add_tt_filters
1805
1806 $content = add_tt_filters( $content );
1807
1808 Add TT filters to some specific fields if needed.
1809
1810 For now we only add the Remove_MARC_punctuation TT filter to biblio and biblioitem fields
1811
1812 =cut
1813
1814 sub add_tt_filters {
1815     my ( $content ) = @_;
1816     $content =~ s|\[%\s*biblio\.(.*?)\s*%\]|[% biblio.$1 \| \$Remove_MARC_punctuation %]|gxms;
1817     $content =~ s|\[%\s*biblioitem\.(.*?)\s*%\]|[% biblioitem.$1 \| \$Remove_MARC_punctuation %]|gxms;
1818     return $content;
1819 }
1820
1821 =head2 get_item_content
1822
1823     my $item = Koha::Items->find(...)->unblessed;
1824     my @item_content_fields = qw( date_due title barcode author itemnumber );
1825     my $item_content = C4::Letters::get_item_content({
1826                              item => $item,
1827                              item_content_fields => \@item_content_fields
1828                        });
1829
1830 This function generates a tab-separated list of values for the passed item. Dates
1831 are formatted following the current setup.
1832
1833 =cut
1834
1835 sub get_item_content {
1836     my ( $params ) = @_;
1837     my $item = $params->{item};
1838     my $dateonly = $params->{dateonly} || 0;
1839     my $item_content_fields = $params->{item_content_fields} || [];
1840
1841     return unless $item;
1842
1843     my @item_info = map {
1844         $_ =~ /^date|date$/
1845           ? eval {
1846             output_pref(
1847                 { dt => dt_from_string( $item->{$_} ), dateonly => $dateonly } );
1848           }
1849           : $item->{$_}
1850           || ''
1851     } @$item_content_fields;
1852     return join( "\t", @item_info ) . "\n";
1853 }
1854
1855 1;
1856 __END__