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