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