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