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