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 'opac_news'    )    ? "SELECT * FROM $table WHERE          idnew = ?"                                  :
 779     ($table eq 'article_requests') ? "SELECT * FROM $table WHERE             id = ?"                                  :
 780     ($table eq 'borrower_modifications') ? "SELECT * FROM $table WHERE verification_token = ?" :
 781     ($table eq 'subscription') ? "SELECT * FROM $table WHERE subscriptionid = ?" :
 782     ($table eq 'serial') ? "SELECT * FROM $table WHERE serialid = ?" :
 783     ($table eq 'problem_reports') ? "SELECT * FROM $table WHERE reportid = ?" :
 784     undef ;
 785     unless ($query) {
 786         warn "ERROR: No _parseletter_sth query for table '$table'";
 787         return;     # nothing to get
 788     }
 789     unless ($sth = C4::Context->dbh->prepare_cached($query)) {
 790         warn "ERROR: Failed to prepare query: '$query'";
 791         return;
 792     }
 793     return $sth;    # now cache is populated for that $table
 794 }
 795
 796 =head2 _parseletter($letter, $table, $values)
 797
 798     parameters :
 799     - $letter : a hash to letter fields (title & content useful)
 800     - $table : the Koha table to parse.
 801     - $values_in : table record hashref
 802     parse all fields from a table, and replace values in title & content with the appropriate value
 803     (not exported sub, used only internally)
 804
 805 =cut
 806
 807 sub _parseletter {
 808     my ( $letter, $table, $values_in ) = @_;
 809
 810     # Work on a local copy of $values_in (passed by reference) to avoid side effects
 811     # in callers ( by changing / formatting values )
 812     my $values = $values_in ? { %$values_in } : {};
 813
 814     if ( $table eq 'borrowers' && $values->{'dateexpiry'} ){
 815         $values->{'dateexpiry'} = output_pref({ dt => dt_from_string( $values->{'dateexpiry'} ), dateonly => 1 });
 816     }
 817
 818     if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
 819         $values->{'waitingdate'} = output_pref({ dt => dt_from_string( $values->{'waitingdate'} ), dateonly => 1 });
 820     }
 821
 822     if ($letter->{content} && $letter->{content} =~ /<<today>>/) {
 823         my $todaysdate = output_pref( dt_from_string() );
 824         $letter->{content} =~ s/<<today>>/$todaysdate/go;
 825     }
 826
 827     while ( my ($field, $val) = each %$values ) {
 828         $val =~ s/\p{P}$// if $val && $table=~/biblio/;
 829             #BZ 9886: Assuming that we want to eliminate ISBD punctuation here
 830             #Therefore adding the test on biblio. This includes biblioitems,
 831             #but excludes items. Removed unneeded global and lookahead.
 832
 833         if ( $table=~/^borrowers$/ && $field=~/^streettype$/ ) {
 834             my $av = Koha::AuthorisedValues->search({ category => 'ROADTYPE', authorised_value => $val });
 835             $val = $av->count ? $av->next->lib : '';
 836         }
 837
 838         # Dates replacement
 839         my $replacedby   = defined ($val) ? $val : '';
 840         if (    $replacedby
 841             and not $replacedby =~ m|0000-00-00|
 842             and not $replacedby =~ m|9999-12-31|
 843             and $replacedby =~ m|^\d{4}-\d{2}-\d{2}( \d{2}:\d{2}:\d{2})?$| )
 844         {
 845             # If the value is XXXX-YY-ZZ[ AA:BB:CC] we assume it is a date
 846             my $dateonly = defined $1 ? 0 : 1; #$1 refers to the capture group wrapped in parentheses. In this case, that's the hours, minutes, seconds.
 847             my $re_dateonly_filter = qr{ $field( \s* \| \s* dateonly\s*)?>> }xms;
 848
 849             for my $letter_field ( qw( title content ) ) {
 850                 my $filter_string_used = q{};
 851                 if ( $letter->{ $letter_field } =~ $re_dateonly_filter ) {
 852                     # We overwrite $dateonly if the filter exists and we have a time in the datetime
 853                     $filter_string_used = $1 || q{};
 854                     $dateonly = $1 unless $dateonly;
 855                 }
 856                 my $replacedby_date = eval {
 857                     output_pref({ dt => dt_from_string( $replacedby ), dateonly => $dateonly });
 858                 };
 859
 860                 if ( $letter->{ $letter_field } ) {
 861                     $letter->{ $letter_field } =~ s/\Q<<$table.$field$filter_string_used>>\E/$replacedby_date/g;
 862                     $letter->{ $letter_field } =~ s/\Q<<$field$filter_string_used>>\E/$replacedby_date/g;
 863                 }
 864             }
 865         }
 866         # Other fields replacement
 867         else {
 868             for my $letter_field ( qw( title content ) ) {
 869                 if ( $letter->{ $letter_field } ) {
 870                     $letter->{ $letter_field }   =~ s/<<$table.$field>>/$replacedby/g;
 871                     $letter->{ $letter_field }   =~ s/<<$field>>/$replacedby/g;
 872                 }
 873             }
 874         }
 875     }
 876
 877     if ($table eq 'borrowers' && $letter->{content}) {
 878         my $patron = Koha::Patrons->find( $values->{borrowernumber} );
 879         if ( $patron ) {
 880             my $attributes = $patron->extended_attributes;
 881             my %attr;
 882             while ( my $attribute = $attributes->next ) {
 883                 my $code = $attribute->code;
 884                 my $val  = $attribute->description; # FIXME - we always display intranet description here!
 885                 $val =~ s/\p{P}(?=$)//g if $val;
 886                 next unless $val gt '';
 887                 $attr{$code} ||= [];
 888                 push @{ $attr{$code} }, $val;
 889             }
 890             while ( my ($code, $val_ar) = each %attr ) {
 891                 my $replacefield = "<<borrower-attribute:$code>>";
 892                 my $replacedby   = join ',', @$val_ar;
 893                 $letter->{content} =~ s/$replacefield/$replacedby/g;
 894             }
 895         }
 896     }
 897     return $letter;
 898 }
 899
 900 =head2 EnqueueLetter
 901
 902   my $success = EnqueueLetter( { letter => $letter,
 903         borrowernumber => '12', message_transport_type => 'email' } )
 904
 905 places a letter in the message_queue database table, which will
 906 eventually get processed (sent) by the process_message_queue.pl
 907 cronjob when it calls SendQueuedMessages.
 908
 909 return message_id on success
 910
 911 =cut
 912
 913 sub EnqueueLetter {
 914     my $params = shift or return;
 915
 916     return unless exists $params->{'letter'};
 917 #   return unless exists $params->{'borrowernumber'};
 918     return unless exists $params->{'message_transport_type'};
 919
 920     my $content = $params->{letter}->{content};
 921     $content =~ s/\s+//g if(defined $content);
 922     if ( not defined $content or $content eq '' ) {
 923         warn "Trying to add an empty message to the message queue" if $debug;
 924         return;
 925     }
 926
 927     # If we have any attachments we should encode then into the body.
 928     if ( $params->{'attachments'} ) {
 929         $params->{'letter'} = _add_attachments(
 930             {   letter      => $params->{'letter'},
 931                 attachments => $params->{'attachments'},
 932                 message     => MIME::Lite->new( Type => 'multipart/mixed' ),
 933             }
 934         );
 935     }
 936
 937     my $dbh       = C4::Context->dbh();
 938     my $statement = << 'ENDSQL';
 939 INSERT INTO message_queue
 940 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, reply_address, content_type )
 941 VALUES
 942 ( ?,              ?,       ?,       ?,        ?,           ?,                      ?,      NOW(),       ?,          ?,            ?,           ? )
 943 ENDSQL
 944
 945     my $sth    = $dbh->prepare($statement);
 946     my $result = $sth->execute(
 947         $params->{'borrowernumber'},              # borrowernumber
 948         $params->{'letter'}->{'title'},           # subject
 949         $params->{'letter'}->{'content'},         # content
 950         $params->{'letter'}->{'metadata'} || '',  # metadata
 951         $params->{'letter'}->{'code'}     || '',  # letter_code
 952         $params->{'message_transport_type'},      # message_transport_type
 953         'pending',                                # status
 954         $params->{'to_address'},                  # to_address
 955         $params->{'from_address'},                # from_address
 956         $params->{'reply_address'},               # reply_address
 957         $params->{'letter'}->{'content-type'},    # content_type
 958     );
 959     return $dbh->last_insert_id(undef,undef,'message_queue', undef);
 960 }
 961
 962 =head2 SendQueuedMessages ([$hashref])
 963
 964     my $sent = SendQueuedMessages({
 965         letter_code => $letter_code,
 966         borrowernumber => $who_letter_is_for,
 967         limit => 50,
 968         verbose => 1,
 969         type => 'sms',
 970     });
 971
 972 Sends all of the 'pending' items in the message queue, unless
 973 parameters are passed.
 974
 975 The letter_code, borrowernumber and limit parameters are used
 976 to build a parameter set for _get_unsent_messages, thus limiting
 977 which pending messages will be processed. They are all optional.
 978
 979 The verbose parameter can be used to generate debugging output.
 980 It is also optional.
 981
 982 Returns number of messages sent.
 983
 984 =cut
 985
 986 sub SendQueuedMessages {
 987     my $params = shift;
 988
 989     my $which_unsent_messages  = {
 990         'limit'          => $params->{'limit'} // 0,
 991         'borrowernumber' => $params->{'borrowernumber'} // q{},
 992         'letter_code'    => $params->{'letter_code'} // q{},
 993         'type'           => $params->{'type'} // q{},
 994     };
 995     my $unsent_messages = _get_unsent_messages( $which_unsent_messages );
 996     MESSAGE: foreach my $message ( @$unsent_messages ) {
 997         my $message_object = Koha::Notice::Messages->find( $message->{message_id} );
 998         # If this fails the database is unwritable and we won't manage to send a message that continues to be marked 'pending'
 999         $message_object->make_column_dirty('status');
1000         return unless $message_object->store;
1001
1002         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
1003         warn sprintf( 'sending %s message to patron: %s',
1004                       $message->{'message_transport_type'},
1005                       $message->{'borrowernumber'} || 'Admin' )
1006           if $params->{'verbose'} or $debug;
1007         # This is just begging for subclassing
1008         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
1009         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
1010             _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
1011         }
1012         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
1013             if ( C4::Context->preference('SMSSendDriver') eq 'Email' ) {
1014                 my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1015                 my $sms_provider = Koha::SMS::Providers->find( $patron->sms_provider_id );
1016                 unless ( $sms_provider ) {
1017                     warn sprintf( "Patron %s has no sms provider id set!", $message->{'borrowernumber'} ) if $params->{'verbose'} or $debug;
1018                     _set_message_status( { message_id => $message->{'message_id'}, status => 'failed' } );
1019                     next MESSAGE;
1020                 }
1021                 unless ( $patron->smsalertnumber ) {
1022                     _set_message_status( { message_id => $message->{'message_id'}, status => 'failed' } );
1023                     warn sprintf( "No smsalertnumber found for patron %s!", $message->{'borrowernumber'} ) if $params->{'verbose'} or $debug;
1024                     next MESSAGE;
1025                 }
1026                 $message->{to_address}  = $patron->smsalertnumber; #Sometime this is set to email - sms should always use smsalertnumber
1027                 $message->{to_address} .= '@' . $sms_provider->domain();
1028
1029                 # Check for possible from_address override
1030                 my $from_address = C4::Context->preference('EmailSMSSendDriverFromAddress');
1031                 if ($from_address && $message->{from_address} ne $from_address) {
1032                     $message->{from_address} = $from_address;
1033                     _update_message_from_address($message->{'message_id'}, $message->{from_address});
1034                 }
1035
1036                 _update_message_to_address($message->{'message_id'}, $message->{to_address});
1037                 _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
1038             } else {
1039                 _send_message_by_sms( $message );
1040             }
1041         }
1042     }
1043     return scalar( @$unsent_messages );
1044 }
1045
1046 =head2 GetRSSMessages
1047
1048   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
1049
1050 returns a listref of all queued RSS messages for a particular person.
1051
1052 =cut
1053
1054 sub GetRSSMessages {
1055     my $params = shift;
1056
1057     return unless $params;
1058     return unless ref $params;
1059     return unless $params->{'borrowernumber'};
1060
1061     return _get_unsent_messages( { message_transport_type => 'rss',
1062                                    limit                  => $params->{'limit'},
1063                                    borrowernumber         => $params->{'borrowernumber'}, } );
1064 }
1065
1066 =head2 GetPrintMessages
1067
1068   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
1069
1070 Returns a arrayref of all queued print messages (optionally, for a particular
1071 person).
1072
1073 =cut
1074
1075 sub GetPrintMessages {
1076     my $params = shift || {};
1077
1078     return _get_unsent_messages( { message_transport_type => 'print',
1079                                    borrowernumber         => $params->{'borrowernumber'},
1080                                  } );
1081 }
1082
1083 =head2 GetQueuedMessages ([$hashref])
1084
1085   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
1086
1087 Fetches a list of messages from the message queue optionally filtered by borrowernumber
1088 and limited to specified limit.
1089
1090 Return is an arrayref of hashes, each has represents a message in the message queue.
1091
1092 =cut
1093
1094 sub GetQueuedMessages {
1095     my $params = shift;
1096
1097     my $dbh = C4::Context->dbh();
1098     my $statement = << 'ENDSQL';
1099 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued, updated_on
1100 FROM message_queue
1101 ENDSQL
1102
1103     my @query_params;
1104     my @whereclauses;
1105     if ( exists $params->{'borrowernumber'} ) {
1106         push @whereclauses, ' borrowernumber = ? ';
1107         push @query_params, $params->{'borrowernumber'};
1108     }
1109
1110     if ( @whereclauses ) {
1111         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
1112     }
1113
1114     if ( defined $params->{'limit'} ) {
1115         $statement .= ' LIMIT ? ';
1116         push @query_params, $params->{'limit'};
1117     }
1118
1119     my $sth = $dbh->prepare( $statement );
1120     my $result = $sth->execute( @query_params );
1121     return $sth->fetchall_arrayref({});
1122 }
1123
1124 =head2 GetMessageTransportTypes
1125
1126   my @mtt = GetMessageTransportTypes();
1127
1128   returns an arrayref of transport types
1129
1130 =cut
1131
1132 sub GetMessageTransportTypes {
1133     my $dbh = C4::Context->dbh();
1134     my $mtts = $dbh->selectcol_arrayref("
1135         SELECT message_transport_type
1136         FROM message_transport_types
1137         ORDER BY message_transport_type
1138     ");
1139     return $mtts;
1140 }
1141
1142 =head2 GetMessage
1143
1144     my $message = C4::Letters::Message($message_id);
1145
1146 =cut
1147
1148 sub GetMessage {
1149     my ( $message_id ) = @_;
1150     return unless $message_id;
1151     my $dbh = C4::Context->dbh;
1152     return $dbh->selectrow_hashref(q|
1153         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
1154         FROM message_queue
1155         WHERE message_id = ?
1156     |, {}, $message_id );
1157 }
1158
1159 =head2 ResendMessage
1160
1161   Attempt to resend a message which has failed previously.
1162
1163   my $has_been_resent = C4::Letters::ResendMessage($message_id);
1164
1165   Updates the message to 'pending' status so that
1166   it will be resent later on.
1167
1168   returns 1 on success, 0 on failure, undef if no message was found
1169
1170 =cut
1171
1172 sub ResendMessage {
1173     my $message_id = shift;
1174     return unless $message_id;
1175
1176     my $message = GetMessage( $message_id );
1177     return unless $message;
1178     my $rv = 0;
1179     if ( $message->{status} ne 'pending' ) {
1180         $rv = C4::Letters::_set_message_status({
1181             message_id => $message_id,
1182             status => 'pending',
1183         });
1184         $rv = $rv > 0? 1: 0;
1185         # Clear destination email address to force address update
1186         _update_message_to_address( $message_id, undef ) if $rv &&
1187             $message->{message_transport_type} eq 'email';
1188     }
1189     return $rv;
1190 }
1191
1192 =head2 _add_attachements
1193
1194   named parameters:
1195   letter - the standard letter hashref
1196   attachments - listref of attachments. each attachment is a hashref of:
1197     type - the mime type, like 'text/plain'
1198     content - the actual attachment
1199     filename - the name of the attachment.
1200   message - a MIME::Lite object to attach these to.
1201
1202   returns your letter object, with the content updated.
1203
1204 =cut
1205
1206 sub _add_attachments {
1207     my $params = shift;
1208
1209     my $letter = $params->{'letter'};
1210     my $attachments = $params->{'attachments'};
1211     return $letter unless @$attachments;
1212     my $message = $params->{'message'};
1213
1214     # First, we have to put the body in as the first attachment
1215     $message->attach(
1216         Type => $letter->{'content-type'} || 'TEXT',
1217         Data => $letter->{'is_html'}
1218             ? _wrap_html($letter->{'content'}, $letter->{'title'})
1219             : $letter->{'content'},
1220     );
1221
1222     foreach my $attachment ( @$attachments ) {
1223         $message->attach(
1224             Type     => $attachment->{'type'},
1225             Data     => $attachment->{'content'},
1226             Filename => $attachment->{'filename'},
1227         );
1228     }
1229     # we're forcing list context here to get the header, not the count back from grep.
1230     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
1231     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
1232     $letter->{'content'} = $message->body_as_string;
1233
1234     return $letter;
1235
1236 }
1237
1238 =head2 _get_unsent_messages
1239
1240   This function's parameter hash reference takes the following
1241   optional named parameters:
1242    message_transport_type: method of message sending (e.g. email, sms, etc.)
1243    borrowernumber        : who the message is to be sent
1244    letter_code           : type of message being sent (e.g. PASSWORD_RESET)
1245    limit                 : maximum number of messages to send
1246
1247   This function returns an array of matching hash referenced rows from
1248   message_queue with some borrower information added.
1249
1250 =cut
1251
1252 sub _get_unsent_messages {
1253     my $params = shift;
1254
1255     my $dbh = C4::Context->dbh();
1256     my $statement = qq{
1257         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
1258         FROM message_queue mq
1259         LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
1260         WHERE status = ?
1261     };
1262
1263     my @query_params = ('pending');
1264     if ( ref $params ) {
1265         if ( $params->{'message_transport_type'} ) {
1266             $statement .= ' AND mq.message_transport_type = ? ';
1267             push @query_params, $params->{'message_transport_type'};
1268         }
1269         if ( $params->{'borrowernumber'} ) {
1270             $statement .= ' AND mq.borrowernumber = ? ';
1271             push @query_params, $params->{'borrowernumber'};
1272         }
1273         if ( $params->{'letter_code'} ) {
1274             $statement .= ' AND mq.letter_code = ? ';
1275             push @query_params, $params->{'letter_code'};
1276         }
1277         if ( $params->{'type'} ) {
1278             $statement .= ' AND message_transport_type = ? ';
1279             push @query_params, $params->{'type'};
1280         }
1281         if ( $params->{'limit'} ) {
1282             $statement .= ' limit ? ';
1283             push @query_params, $params->{'limit'};
1284         }
1285     }
1286
1287     $debug and warn "_get_unsent_messages SQL: $statement";
1288     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
1289     my $sth = $dbh->prepare( $statement );
1290     my $result = $sth->execute( @query_params );
1291     return $sth->fetchall_arrayref({});
1292 }
1293
1294 sub _send_message_by_email {
1295     my $message = shift or return;
1296     my ($username, $password, $method) = @_;
1297
1298     my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1299     my $to_address = $message->{'to_address'};
1300     unless ($to_address) {
1301         unless ($patron) {
1302             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
1303             _set_message_status( { message_id => $message->{'message_id'},
1304                                    status     => 'failed' } );
1305             return;
1306         }
1307         $to_address = $patron->notice_email_address;
1308         unless ($to_address) {
1309             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
1310             # warning too verbose for this more common case?
1311             _set_message_status( { message_id => $message->{'message_id'},
1312                                    status     => 'failed' } );
1313             return;
1314         }
1315     }
1316
1317     # Encode subject line separately
1318     $message->{subject} = encode('MIME-Header', $message->{'subject'} );
1319     my $subject = $message->{'subject'};
1320
1321     my $content = encode('UTF-8', $message->{'content'});
1322     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
1323     my $is_html = $content_type =~ m/html/io;
1324
1325     my $branch_email = undef;
1326     my $branch_replyto = undef;
1327     my $branch_returnpath = undef;
1328     my $library;
1329
1330     if ($patron) {
1331         $library           = $patron->library;
1332         $branch_email      = $library->branchemail;
1333         $branch_replyto    = $library->branchreplyto;
1334         $branch_returnpath = $library->branchreturnpath;
1335     }
1336
1337     my $email = Koha::Email->create(
1338         {
1339             to => $to_address,
1340             (
1341                 C4::Context->preference('NoticeBcc')
1342                 ? ( bcc => C4::Context->preference('NoticeBcc') )
1343                 : ()
1344             ),
1345             from     => $message->{'from_address'}  || $branch_email,
1346             reply_to => $message->{'reply_address'} || $branch_replyto,
1347             sender   => $branch_returnpath,
1348             subject  => "" . $message->{subject}
1349         }
1350     );
1351
1352     if ( $is_html ) {
1353         $email->html_body(
1354             _wrap_html( $content, $subject )
1355         );
1356     }
1357     else {
1358         $email->text_body( $content );
1359     }
1360
1361     my $smtp_server;
1362     if ( $library ) {
1363         $smtp_server = $library->smtp_server;
1364     }
1365     else {
1366         $smtp_server = Koha::SMTP::Servers->get_default;
1367     }
1368
1369     if ( $username ) {
1370         $smtp_server->set(
1371             {
1372                 sasl_username => $username,
1373                 sasl_password => $password,
1374             }
1375         );
1376     }
1377
1378 # if initial message address was empty, coming here means that a to address was found and
1379 # queue should be updated; same if to address was overriden by Koha::Email->create
1380     _update_message_to_address( $message->{'message_id'}, $email->email->header('To') )
1381       if !$message->{to_address}
1382       || $message->{to_address} ne $email->email->header('To');
1383
1384     try {
1385         $email->send_or_die({ transport => $smtp_server->transport });
1386
1387         _set_message_status(
1388             {
1389                 message_id => $message->{'message_id'},
1390                 status     => 'sent'
1391             }
1392         );
1393         return 1;
1394     }
1395     catch {
1396         _set_message_status(
1397             {
1398                 message_id => $message->{'message_id'},
1399                 status     => 'failed'
1400             }
1401         );
1402         carp "$_";
1403         return;
1404     };
1405 }
1406
1407 sub _wrap_html {
1408     my ($content, $title) = @_;
1409
1410     my $css = C4::Context->preference("NoticeCSS") || '';
1411     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
1412     return <<EOS;
1413 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1414     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1415 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1416 <head>
1417 <title>$title</title>
1418 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1419 $css
1420 </head>
1421 <body>
1422 $content
1423 </body>
1424 </html>
1425 EOS
1426 }
1427
1428 sub _is_duplicate {
1429     my ( $message ) = @_;
1430     my $dbh = C4::Context->dbh;
1431     my $count = $dbh->selectrow_array(q|
1432         SELECT COUNT(*)
1433         FROM message_queue
1434         WHERE message_transport_type = ?
1435         AND borrowernumber = ?
1436         AND letter_code = ?
1437         AND CAST(updated_on AS date) = CAST(NOW() AS date)
1438         AND status="sent"
1439         AND content = ?
1440     |, {}, $message->{message_transport_type}, $message->{borrowernumber}, $message->{letter_code}, $message->{content} );
1441     return $count;
1442 }
1443
1444 sub _send_message_by_sms {
1445     my $message = shift or return;
1446     my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1447
1448     unless ( $patron and $patron->smsalertnumber ) {
1449         _set_message_status( { message_id => $message->{'message_id'},
1450                                status     => 'failed' } );
1451         return;
1452     }
1453
1454     if ( _is_duplicate( $message ) ) {
1455         _set_message_status( { message_id => $message->{'message_id'},
1456                                status     => 'failed' } );
1457         return;
1458     }
1459
1460     my $success = C4::SMS->send_sms( { destination => $patron->smsalertnumber,
1461                                        message     => $message->{'content'},
1462                                      } );
1463     _set_message_status( { message_id => $message->{'message_id'},
1464                            status     => ($success ? 'sent' : 'failed') } );
1465     return $success;
1466 }
1467
1468 sub _update_message_to_address {
1469     my ($id, $to)= @_;
1470     my $dbh = C4::Context->dbh();
1471     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1472 }
1473
1474 sub _update_message_from_address {
1475     my ($message_id, $from_address) = @_;
1476     my $dbh = C4::Context->dbh();
1477     $dbh->do('UPDATE message_queue SET from_address = ? WHERE message_id = ?', undef, ($from_address, $message_id));
1478 }
1479
1480 sub _set_message_status {
1481     my $params = shift or return;
1482
1483     foreach my $required_parameter ( qw( message_id status ) ) {
1484         return unless exists $params->{ $required_parameter };
1485     }
1486
1487     my $dbh = C4::Context->dbh();
1488     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1489     my $sth = $dbh->prepare( $statement );
1490     my $result = $sth->execute( $params->{'status'},
1491                                 $params->{'message_id'} );
1492     return $result;
1493 }
1494
1495 sub _process_tt {
1496     my ( $params ) = @_;
1497
1498     my $content = $params->{content};
1499     my $tables = $params->{tables};
1500     my $loops = $params->{loops};
1501     my $substitute = $params->{substitute} || {};
1502
1503     my $use_template_cache = C4::Context->config('template_cache_dir') && defined $ENV{GATEWAY_INTERFACE};
1504     my $template           = Template->new(
1505         {
1506             EVAL_PERL    => 1,
1507             ABSOLUTE     => 1,
1508             PLUGIN_BASE  => 'Koha::Template::Plugin',
1509             COMPILE_EXT  => $use_template_cache ? '.ttc' : '',
1510             COMPILE_DIR  => $use_template_cache ? C4::Context->config('template_cache_dir') : '',
1511             FILTERS      => {},
1512             ENCODING     => 'UTF-8',
1513         }
1514     ) or die Template->error();
1515
1516     my $tt_params = { %{ _get_tt_params( $tables ) }, %{ _get_tt_params( $loops, 'is_a_loop' ) }, %$substitute };
1517
1518     $content = add_tt_filters( $content );
1519     $content = qq|[% USE KohaDates %][% USE Remove_MARC_punctuation %]$content|;
1520
1521     my $output;
1522     $template->process( \$content, $tt_params, \$output ) || croak "ERROR PROCESSING TEMPLATE: " . $template->error();
1523
1524     return $output;
1525 }
1526
1527 sub _get_tt_params {
1528     my ($tables, $is_a_loop) = @_;
1529
1530     my $params;
1531     $is_a_loop ||= 0;
1532
1533     my $config = {
1534         article_requests => {
1535             module   => 'Koha::ArticleRequests',
1536             singular => 'article_request',
1537             plural   => 'article_requests',
1538             pk       => 'id',
1539         },
1540         aqbasket => {
1541             module   => 'Koha::Acquisition::Baskets',
1542             singular => 'basket',
1543             plural   => 'baskets',
1544             pk       => 'basketno',
1545         },
1546         biblio => {
1547             module   => 'Koha::Biblios',
1548             singular => 'biblio',
1549             plural   => 'biblios',
1550             pk       => 'biblionumber',
1551         },
1552         biblioitems => {
1553             module   => 'Koha::Biblioitems',
1554             singular => 'biblioitem',
1555             plural   => 'biblioitems',
1556             pk       => 'biblioitemnumber',
1557         },
1558         borrowers => {
1559             module   => 'Koha::Patrons',
1560             singular => 'borrower',
1561             plural   => 'borrowers',
1562             pk       => 'borrowernumber',
1563         },
1564         branches => {
1565             module   => 'Koha::Libraries',
1566             singular => 'branch',
1567             plural   => 'branches',
1568             pk       => 'branchcode',
1569         },
1570         items => {
1571             module   => 'Koha::Items',
1572             singular => 'item',
1573             plural   => 'items',
1574             pk       => 'itemnumber',
1575         },
1576         opac_news => {
1577             module   => 'Koha::News',
1578             singular => 'news',
1579             plural   => 'news',
1580             pk       => 'idnew',
1581         },
1582         aqorders => {
1583             module   => 'Koha::Acquisition::Orders',
1584             singular => 'order',
1585             plural   => 'orders',
1586             pk       => 'ordernumber',
1587         },
1588         reserves => {
1589             module   => 'Koha::Holds',
1590             singular => 'hold',
1591             plural   => 'holds',
1592             pk       => 'reserve_id',
1593         },
1594         serial => {
1595             module   => 'Koha::Serials',
1596             singular => 'serial',
1597             plural   => 'serials',
1598             pk       => 'serialid',
1599         },
1600         subscription => {
1601             module   => 'Koha::Subscriptions',
1602             singular => 'subscription',
1603             plural   => 'subscriptions',
1604             pk       => 'subscriptionid',
1605         },
1606         suggestions => {
1607             module   => 'Koha::Suggestions',
1608             singular => 'suggestion',
1609             plural   => 'suggestions',
1610             pk       => 'suggestionid',
1611         },
1612         issues => {
1613             module   => 'Koha::Checkouts',
1614             singular => 'checkout',
1615             plural   => 'checkouts',
1616             fk       => 'itemnumber',
1617         },
1618         old_issues => {
1619             module   => 'Koha::Old::Checkouts',
1620             singular => 'old_checkout',
1621             plural   => 'old_checkouts',
1622             fk       => 'itemnumber',
1623         },
1624         overdues => {
1625             module   => 'Koha::Checkouts',
1626             singular => 'overdue',
1627             plural   => 'overdues',
1628             fk       => 'itemnumber',
1629         },
1630         borrower_modifications => {
1631             module   => 'Koha::Patron::Modifications',
1632             singular => 'patron_modification',
1633             plural   => 'patron_modifications',
1634             fk       => 'verification_token',
1635         },
1636     };
1637
1638     foreach my $table ( keys %$tables ) {
1639         next unless $config->{$table};
1640
1641         my $ref = ref( $tables->{$table} ) || q{};
1642         my $module = $config->{$table}->{module};
1643
1644         if ( can_load( modules => { $module => undef } ) ) {
1645             my $pk = $config->{$table}->{pk};
1646             my $fk = $config->{$table}->{fk};
1647
1648             if ( $is_a_loop ) {
1649                 my $values = $tables->{$table} || [];
1650                 unless ( ref( $values ) eq 'ARRAY' ) {
1651                     croak "ERROR processing table $table. Wrong API call.";
1652                 }
1653                 my $key = $pk ? $pk : $fk;
1654                 # $key does not come from user input
1655                 my $objects = $module->search(
1656                     { $key => $values },
1657                     {
1658                             # We want to retrieve the data in the same order
1659                             # FIXME MySQLism
1660                             # field is a MySQLism, but they are no other way to do it
1661                             # To be generic we could do it in perl, but we will need to fetch
1662                             # all the data then order them
1663                         @$values ? ( order_by => \[ "field($key, " . join( ', ', @$values ) . ")" ] ) : ()
1664                     }
1665                 );
1666                 $params->{ $config->{$table}->{plural} } = $objects;
1667             }
1668             elsif ( $ref eq q{} || $ref eq 'HASH' ) {
1669                 my $id = ref $ref eq 'HASH' ? $tables->{$table}->{$pk} : $tables->{$table};
1670                 my $object;
1671                 if ( $fk ) { # Using a foreign key for lookup
1672                     if ( ref( $fk ) eq 'ARRAY' ) { # Foreign key is multi-column
1673                         my $search;
1674                         foreach my $key ( @$fk ) {
1675                             $search->{$key} = $id->{$key};
1676                         }
1677                         $object = $module->search( $search )->last();
1678                     } else { # Foreign key is single column
1679                         $object = $module->search( { $fk => $id } )->last();
1680                     }
1681                 } else { # using the table's primary key for lookup
1682                     $object = $module->find($id);
1683                 }
1684                 $params->{ $config->{$table}->{singular} } = $object;
1685             }
1686             else {    # $ref eq 'ARRAY'
1687                 my $object;
1688                 if ( @{ $tables->{$table} } == 1 ) {    # Param is a single key
1689                     $object = $module->search( { $pk => $tables->{$table} } )->last();
1690                 }
1691                 else {                                  # Params are mutliple foreign keys
1692                     croak "Multiple foreign keys (table $table) should be passed using an hashref";
1693                 }
1694                 $params->{ $config->{$table}->{singular} } = $object;
1695             }
1696         }
1697         else {
1698             croak "ERROR LOADING MODULE $module: $Module::Load::Conditional::ERROR";
1699         }
1700     }
1701
1702     $params->{today} = output_pref({ dt => dt_from_string, dateformat => 'iso' });
1703
1704     return $params;
1705 }
1706
1707 =head3 add_tt_filters
1708
1709 $content = add_tt_filters( $content );
1710
1711 Add TT filters to some specific fields if needed.
1712
1713 For now we only add the Remove_MARC_punctuation TT filter to biblio and biblioitem fields
1714
1715 =cut
1716
1717 sub add_tt_filters {
1718     my ( $content ) = @_;
1719     $content =~ s|\[%\s*biblio\.(.*?)\s*%\]|[% biblio.$1 \| \$Remove_MARC_punctuation %]|gxms;
1720     $content =~ s|\[%\s*biblioitem\.(.*?)\s*%\]|[% biblioitem.$1 \| \$Remove_MARC_punctuation %]|gxms;
1721     return $content;
1722 }
1723
1724 =head2 get_item_content
1725
1726     my $item = Koha::Items->find(...)->unblessed;
1727     my @item_content_fields = qw( date_due title barcode author itemnumber );
1728     my $item_content = C4::Letters::get_item_content({
1729                              item => $item,
1730                              item_content_fields => \@item_content_fields
1731                        });
1732
1733 This function generates a tab-separated list of values for the passed item. Dates
1734 are formatted following the current setup.
1735
1736 =cut
1737
1738 sub get_item_content {
1739     my ( $params ) = @_;
1740     my $item = $params->{item};
1741     my $dateonly = $params->{dateonly} || 0;
1742     my $item_content_fields = $params->{item_content_fields} || [];
1743
1744     return unless $item;
1745
1746     my @item_info = map {
1747         $_ =~ /^date|date$/
1748           ? eval {
1749             output_pref(
1750                 { dt => dt_from_string( $item->{$_} ), dateonly => $dateonly } );
1751           }
1752           : $item->{$_}
1753           || ''
1754     } @$item_content_fields;
1755     return join( "\t", @item_info ) . "\n";
1756 }
1757
1758 1;
1759 __END__