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