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