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