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