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