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