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 $loops  = $params{loops} || {}; # loops is not supported for historical notices syntax
 695     my $repeat = $params{repeat};
 696     %$tables || %$substitute || $repeat || %$loops
 697       or carp( "ERROR: nothing to substitute - both 'tables', 'loops' and 'substitute' are empty" ),
 698          return;
 699     my $want_librarian = $params{want_librarian};
 700
 701     if (%$substitute) {
 702         while ( my ($token, $val) = each %$substitute ) {
 703             if ( $token eq 'items.content' ) {
 704                 $val =~ s|\n|<br/>|g if $letter->{is_html};
 705             }
 706
 707             $letter->{title} =~ s/<<$token>>/$val/g;
 708             $letter->{content} =~ s/<<$token>>/$val/g;
 709        }
 710     }
 711
 712     my $OPACBaseURL = C4::Context->preference('OPACBaseURL');
 713     $letter->{content} =~ s/<<OPACBaseURL>>/$OPACBaseURL/go;
 714
 715     if ($want_librarian) {
 716         # parsing librarian name
 717         my $userenv = C4::Context->userenv;
 718         $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/go;
 719         $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/go;
 720         $letter->{content} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/go;
 721     }
 722
 723     my ($repeat_no_enclosing_tags, $repeat_enclosing_tags);
 724
 725     if ($repeat) {
 726         if (ref ($repeat) eq 'ARRAY' ) {
 727             $repeat_no_enclosing_tags = $repeat;
 728         } else {
 729             $repeat_enclosing_tags = $repeat;
 730         }
 731     }
 732
 733     if ($repeat_enclosing_tags) {
 734         while ( my ($tag, $tag_tables) = each %$repeat_enclosing_tags ) {
 735             if ( $letter->{content} =~ m!<$tag>(.*)</$tag>!s ) {
 736                 my $subcontent = $1;
 737                 my @lines = map {
 738                     my %subletter = ( title => '', content => $subcontent );
 739                     _substitute_tables( \%subletter, $_ );
 740                     $subletter{content};
 741                 } @$tag_tables;
 742                 $letter->{content} =~ s!<$tag>.*</$tag>!join( "\n", @lines )!se;
 743             }
 744         }
 745     }
 746
 747     if (%$tables) {
 748         _substitute_tables( $letter, $tables );
 749     }
 750
 751     if ($repeat_no_enclosing_tags) {
 752         if ( $letter->{content} =~ m/[^\n]*<<.*>>[^\n]*/so ) {
 753             my $line = $&;
 754             my $i = 1;
 755             my @lines = map {
 756                 my $c = $line;
 757                 $c =~ s/<<count>>/$i/go;
 758                 foreach my $field ( keys %{$_} ) {
 759                     $c =~ s/(<<[^\.]+.$field>>)/$_->{$field}/;
 760                 }
 761                 $i++;
 762                 $c;
 763             } @$repeat_no_enclosing_tags;
 764
 765             my $replaceby = join( "\n", @lines );
 766             $letter->{content} =~ s/\Q$line\E/$replaceby/s;
 767         }
 768     }
 769
 770     $letter->{content} = _process_tt(
 771         {
 772             content => $letter->{content},
 773             tables  => $tables,
 774             loops  => $loops,
 775         }
 776     );
 777
 778     $letter->{content} =~ s/<<\S*>>//go; #remove any stragglers
 779
 780     return $letter;
 781 }
 782
 783 sub _substitute_tables {
 784     my ( $letter, $tables ) = @_;
 785     while ( my ($table, $param) = each %$tables ) {
 786         next unless $param;
 787
 788         my $ref = ref $param;
 789
 790         my $values;
 791         if ($ref && $ref eq 'HASH') {
 792             $values = $param;
 793         }
 794         else {
 795             my $sth = _parseletter_sth($table);
 796             unless ($sth) {
 797                 warn "_parseletter_sth('$table') failed to return a valid sth.  No substitution will be done for that table.";
 798                 return;
 799             }
 800             $sth->execute( $ref ? @$param : $param );
 801
 802             $values = $sth->fetchrow_hashref;
 803             $sth->finish();
 804         }
 805
 806         _parseletter ( $letter, $table, $values );
 807     }
 808 }
 809
 810 sub _parseletter_sth {
 811     my $table = shift;
 812     my $sth;
 813     unless ($table) {
 814         carp "ERROR: _parseletter_sth() called without argument (table)";
 815         return;
 816     }
 817     # NOTE: we used to check whether we had a statement handle cached in
 818     #       a %handles module-level variable. This was a dumb move and
 819     #       broke things for the rest of us. prepare_cached is a better
 820     #       way to cache statement handles anyway.
 821     my $query =
 822     ($table eq 'biblio'       )    ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 823     ($table eq 'biblioitems'  )    ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 824     ($table eq 'items'        )    ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 825     ($table eq 'issues'       )    ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 826     ($table eq 'old_issues'   )    ? "SELECT * FROM $table WHERE     itemnumber = ? ORDER BY timestamp DESC LIMIT 1"  :
 827     ($table eq 'reserves'     )    ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?"             :
 828     ($table eq 'borrowers'    )    ? "SELECT * FROM $table WHERE borrowernumber = ?"                                  :
 829     ($table eq 'branches'     )    ? "SELECT * FROM $table WHERE     branchcode = ?"                                  :
 830     ($table eq 'suggestions'  )    ? "SELECT * FROM $table WHERE   suggestionid = ?"                                  :
 831     ($table eq 'aqbooksellers')    ? "SELECT * FROM $table WHERE             id = ?"                                  :
 832     ($table eq 'aqorders'     )    ? "SELECT * FROM $table WHERE    ordernumber = ?"                                  :
 833     ($table eq 'opac_news'    )    ? "SELECT * FROM $table WHERE          idnew = ?"                                  :
 834     ($table eq 'article_requests') ? "SELECT * FROM $table WHERE             id = ?"                                  :
 835     ($table eq 'borrower_modifications') ? "SELECT * FROM $table WHERE verification_token = ?" :
 836     ($table eq 'subscription') ? "SELECT * FROM $table WHERE subscriptionid = ?" :
 837     ($table eq 'serial') ? "SELECT * FROM $table WHERE serialid = ?" :
 838     undef ;
 839     unless ($query) {
 840         warn "ERROR: No _parseletter_sth query for table '$table'";
 841         return;     # nothing to get
 842     }
 843     unless ($sth = C4::Context->dbh->prepare_cached($query)) {
 844         warn "ERROR: Failed to prepare query: '$query'";
 845         return;
 846     }
 847     return $sth;    # now cache is populated for that $table
 848 }
 849
 850 =head2 _parseletter($letter, $table, $values)
 851
 852     parameters :
 853     - $letter : a hash to letter fields (title & content useful)
 854     - $table : the Koha table to parse.
 855     - $values_in : table record hashref
 856     parse all fields from a table, and replace values in title & content with the appropriate value
 857     (not exported sub, used only internally)
 858
 859 =cut
 860
 861 sub _parseletter {
 862     my ( $letter, $table, $values_in ) = @_;
 863
 864     # Work on a local copy of $values_in (passed by reference) to avoid side effects
 865     # in callers ( by changing / formatting values )
 866     my $values = $values_in ? { %$values_in } : {};
 867
 868     if ( $table eq 'borrowers' && $values->{'dateexpiry'} ){
 869         $values->{'dateexpiry'} = format_sqldatetime( $values->{'dateexpiry'} );
 870     }
 871
 872     if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
 873         my @waitingdate = split /-/, $values->{'waitingdate'};
 874
 875         $values->{'expirationdate'} = '';
 876         if ( C4::Context->preference('ReservesMaxPickUpDelay') ) {
 877             my $dt = dt_from_string();
 878             $dt->add( days => C4::Context->preference('ReservesMaxPickUpDelay') );
 879             $values->{'expirationdate'} = output_pref( { dt => $dt, dateonly => 1 } );
 880         }
 881
 882         $values->{'waitingdate'} = output_pref({ dt => dt_from_string( $values->{'waitingdate'} ), dateonly => 1 });
 883
 884     }
 885
 886     if ($letter->{content} && $letter->{content} =~ /<<today>>/) {
 887         my $todaysdate = output_pref( DateTime->now() );
 888         $letter->{content} =~ s/<<today>>/$todaysdate/go;
 889     }
 890
 891     while ( my ($field, $val) = each %$values ) {
 892         $val =~ s/\p{P}$// if $val && $table=~/biblio/;
 893             #BZ 9886: Assuming that we want to eliminate ISBD punctuation here
 894             #Therefore adding the test on biblio. This includes biblioitems,
 895             #but excludes items. Removed unneeded global and lookahead.
 896
 897         if ( $table=~/^borrowers$/ && $field=~/^streettype$/ ) {
 898             my $av = Koha::AuthorisedValues->search({ category => 'ROADTYPE', authorised_value => $val });
 899             $val = $av->count ? $av->next->lib : '';
 900         }
 901
 902         # Dates replacement
 903         my $replacedby   = defined ($val) ? $val : '';
 904         if (    $replacedby
 905             and not $replacedby =~ m|0000-00-00|
 906             and not $replacedby =~ m|9999-12-31|
 907             and $replacedby =~ m|^\d{4}-\d{2}-\d{2}( \d{2}:\d{2}:\d{2})?$| )
 908         {
 909             # If the value is XXXX-YY-ZZ[ AA:BB:CC] we assume it is a date
 910             my $dateonly = defined $1 ? 0 : 1; #$1 refers to the capture group wrapped in parentheses. In this case, that's the hours, minutes, seconds.
 911             my $re_dateonly_filter = qr{ $field( \s* \| \s* dateonly\s*)?>> }xms;
 912
 913             for my $letter_field ( qw( title content ) ) {
 914                 my $filter_string_used = q{};
 915                 if ( $letter->{ $letter_field } =~ $re_dateonly_filter ) {
 916                     # We overwrite $dateonly if the filter exists and we have a time in the datetime
 917                     $filter_string_used = $1 || q{};
 918                     $dateonly = $1 unless $dateonly;
 919                 }
 920                 my $replacedby_date = eval {
 921                     output_pref({ dt => dt_from_string( $replacedby ), dateonly => $dateonly });
 922                 };
 923
 924                 if ( $letter->{ $letter_field } ) {
 925                     $letter->{ $letter_field } =~ s/\Q<<$table.$field$filter_string_used>>\E/$replacedby_date/g;
 926                     $letter->{ $letter_field } =~ s/\Q<<$field$filter_string_used>>\E/$replacedby_date/g;
 927                 }
 928             }
 929         }
 930         # Other fields replacement
 931         else {
 932             for my $letter_field ( qw( title content ) ) {
 933                 if ( $letter->{ $letter_field } ) {
 934                     $letter->{ $letter_field }   =~ s/<<$table.$field>>/$replacedby/g;
 935                     $letter->{ $letter_field }   =~ s/<<$field>>/$replacedby/g;
 936                 }
 937             }
 938         }
 939     }
 940
 941     if ($table eq 'borrowers' && $letter->{content}) {
 942         if ( my $attributes = GetBorrowerAttributes($values->{borrowernumber}) ) {
 943             my %attr;
 944             foreach (@$attributes) {
 945                 my $code = $_->{code};
 946                 my $val  = $_->{value_description} || $_->{value};
 947                 $val =~ s/\p{P}(?=$)//g if $val;
 948                 next unless $val gt '';
 949                 $attr{$code} ||= [];
 950                 push @{ $attr{$code} }, $val;
 951             }
 952             while ( my ($code, $val_ar) = each %attr ) {
 953                 my $replacefield = "<<borrower-attribute:$code>>";
 954                 my $replacedby   = join ',', @$val_ar;
 955                 $letter->{content} =~ s/$replacefield/$replacedby/g;
 956             }
 957         }
 958     }
 959     return $letter;
 960 }
 961
 962 =head2 EnqueueLetter
 963
 964   my $success = EnqueueLetter( { letter => $letter,
 965         borrowernumber => '12', message_transport_type => 'email' } )
 966
 967 places a letter in the message_queue database table, which will
 968 eventually get processed (sent) by the process_message_queue.pl
 969 cronjob when it calls SendQueuedMessages.
 970
 971 return message_id on success
 972
 973 =cut
 974
 975 sub EnqueueLetter {
 976     my $params = shift or return;
 977
 978     return unless exists $params->{'letter'};
 979 #   return unless exists $params->{'borrowernumber'};
 980     return unless exists $params->{'message_transport_type'};
 981
 982     my $content = $params->{letter}->{content};
 983     $content =~ s/\s+//g if(defined $content);
 984     if ( not defined $content or $content eq '' ) {
 985         warn "Trying to add an empty message to the message queue" if $debug;
 986         return;
 987     }
 988
 989     # If we have any attachments we should encode then into the body.
 990     if ( $params->{'attachments'} ) {
 991         $params->{'letter'} = _add_attachments(
 992             {   letter      => $params->{'letter'},
 993                 attachments => $params->{'attachments'},
 994                 message     => MIME::Lite->new( Type => 'multipart/mixed' ),
 995             }
 996         );
 997     }
 998
 999     my $dbh       = C4::Context->dbh();
1000     my $statement = << 'ENDSQL';
1001 INSERT INTO message_queue
1002 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type )
1003 VALUES
1004 ( ?,              ?,       ?,       ?,        ?,           ?,                      ?,      NOW(),       ?,          ?,            ? )
1005 ENDSQL
1006
1007     my $sth    = $dbh->prepare($statement);
1008     my $result = $sth->execute(
1009         $params->{'borrowernumber'},              # borrowernumber
1010         $params->{'letter'}->{'title'},           # subject
1011         $params->{'letter'}->{'content'},         # content
1012         $params->{'letter'}->{'metadata'} || '',  # metadata
1013         $params->{'letter'}->{'code'}     || '',  # letter_code
1014         $params->{'message_transport_type'},      # message_transport_type
1015         'pending',                                # status
1016         $params->{'to_address'},                  # to_address
1017         $params->{'from_address'},                # from_address
1018         $params->{'letter'}->{'content-type'},    # content_type
1019     );
1020     return $dbh->last_insert_id(undef,undef,'message_queue', undef);
1021 }
1022
1023 =head2 SendQueuedMessages ([$hashref])
1024
1025   my $sent = SendQueuedMessages( { verbose => 1 } );
1026
1027 sends all of the 'pending' items in the message queue.
1028
1029 returns number of messages sent.
1030
1031 =cut
1032
1033 sub SendQueuedMessages {
1034     my $params = shift;
1035
1036     my $unsent_messages = _get_unsent_messages();
1037     MESSAGE: foreach my $message ( @$unsent_messages ) {
1038         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
1039         warn sprintf( 'sending %s message to patron: %s',
1040                       $message->{'message_transport_type'},
1041                       $message->{'borrowernumber'} || 'Admin' )
1042           if $params->{'verbose'} or $debug;
1043         # This is just begging for subclassing
1044         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
1045         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
1046             _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
1047         }
1048         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
1049             if ( C4::Context->preference('SMSSendDriver') eq 'Email' ) {
1050                 my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
1051                 my $sms_provider = Koha::SMS::Providers->find( $member->{'sms_provider_id'} );
1052                 $message->{to_address} .= '@' . $sms_provider->domain();
1053                 _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
1054             } else {
1055                 _send_message_by_sms( $message );
1056             }
1057         }
1058     }
1059     return scalar( @$unsent_messages );
1060 }
1061
1062 =head2 GetRSSMessages
1063
1064   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
1065
1066 returns a listref of all queued RSS messages for a particular person.
1067
1068 =cut
1069
1070 sub GetRSSMessages {
1071     my $params = shift;
1072
1073     return unless $params;
1074     return unless ref $params;
1075     return unless $params->{'borrowernumber'};
1076
1077     return _get_unsent_messages( { message_transport_type => 'rss',
1078                                    limit                  => $params->{'limit'},
1079                                    borrowernumber         => $params->{'borrowernumber'}, } );
1080 }
1081
1082 =head2 GetPrintMessages
1083
1084   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
1085
1086 Returns a arrayref of all queued print messages (optionally, for a particular
1087 person).
1088
1089 =cut
1090
1091 sub GetPrintMessages {
1092     my $params = shift || {};
1093
1094     return _get_unsent_messages( { message_transport_type => 'print',
1095                                    borrowernumber         => $params->{'borrowernumber'},
1096                                  } );
1097 }
1098
1099 =head2 GetQueuedMessages ([$hashref])
1100
1101   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
1102
1103 fetches messages out of the message queue.
1104
1105 returns:
1106 list of hashes, each has represents a message in the message queue.
1107
1108 =cut
1109
1110 sub GetQueuedMessages {
1111     my $params = shift;
1112
1113     my $dbh = C4::Context->dbh();
1114     my $statement = << 'ENDSQL';
1115 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued
1116 FROM message_queue
1117 ENDSQL
1118
1119     my @query_params;
1120     my @whereclauses;
1121     if ( exists $params->{'borrowernumber'} ) {
1122         push @whereclauses, ' borrowernumber = ? ';
1123         push @query_params, $params->{'borrowernumber'};
1124     }
1125
1126     if ( @whereclauses ) {
1127         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
1128     }
1129
1130     if ( defined $params->{'limit'} ) {
1131         $statement .= ' LIMIT ? ';
1132         push @query_params, $params->{'limit'};
1133     }
1134
1135     my $sth = $dbh->prepare( $statement );
1136     my $result = $sth->execute( @query_params );
1137     return $sth->fetchall_arrayref({});
1138 }
1139
1140 =head2 GetMessageTransportTypes
1141
1142   my @mtt = GetMessageTransportTypes();
1143
1144   returns an arrayref of transport types
1145
1146 =cut
1147
1148 sub GetMessageTransportTypes {
1149     my $dbh = C4::Context->dbh();
1150     my $mtts = $dbh->selectcol_arrayref("
1151         SELECT message_transport_type
1152         FROM message_transport_types
1153         ORDER BY message_transport_type
1154     ");
1155     return $mtts;
1156 }
1157
1158 =head2 GetMessage
1159
1160     my $message = C4::Letters::Message($message_id);
1161
1162 =cut
1163
1164 sub GetMessage {
1165     my ( $message_id ) = @_;
1166     return unless $message_id;
1167     my $dbh = C4::Context->dbh;
1168     return $dbh->selectrow_hashref(q|
1169         SELECT message_id, borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type
1170         FROM message_queue
1171         WHERE message_id = ?
1172     |, {}, $message_id );
1173 }
1174
1175 =head2 ResendMessage
1176
1177   Attempt to resend a message which has failed previously.
1178
1179   my $has_been_resent = C4::Letters::ResendMessage($message_id);
1180
1181   Updates the message to 'pending' status so that
1182   it will be resent later on.
1183
1184   returns 1 on success, 0 on failure, undef if no message was found
1185
1186 =cut
1187
1188 sub ResendMessage {
1189     my $message_id = shift;
1190     return unless $message_id;
1191
1192     my $message = GetMessage( $message_id );
1193     return unless $message;
1194     my $rv = 0;
1195     if ( $message->{status} ne 'pending' ) {
1196         $rv = C4::Letters::_set_message_status({
1197             message_id => $message_id,
1198             status => 'pending',
1199         });
1200         $rv = $rv > 0? 1: 0;
1201         # Clear destination email address to force address update
1202         _update_message_to_address( $message_id, undef ) if $rv &&
1203             $message->{message_transport_type} eq 'email';
1204     }
1205     return $rv;
1206 }
1207
1208 =head2 _add_attachements
1209
1210 named parameters:
1211 letter - the standard letter hashref
1212 attachments - listref of attachments. each attachment is a hashref of:
1213   type - the mime type, like 'text/plain'
1214   content - the actual attachment
1215   filename - the name of the attachment.
1216 message - a MIME::Lite object to attach these to.
1217
1218 returns your letter object, with the content updated.
1219
1220 =cut
1221
1222 sub _add_attachments {
1223     my $params = shift;
1224
1225     my $letter = $params->{'letter'};
1226     my $attachments = $params->{'attachments'};
1227     return $letter unless @$attachments;
1228     my $message = $params->{'message'};
1229
1230     # First, we have to put the body in as the first attachment
1231     $message->attach(
1232         Type => $letter->{'content-type'} || 'TEXT',
1233         Data => $letter->{'is_html'}
1234             ? _wrap_html($letter->{'content'}, $letter->{'title'})
1235             : $letter->{'content'},
1236     );
1237
1238     foreach my $attachment ( @$attachments ) {
1239         $message->attach(
1240             Type     => $attachment->{'type'},
1241             Data     => $attachment->{'content'},
1242             Filename => $attachment->{'filename'},
1243         );
1244     }
1245     # we're forcing list context here to get the header, not the count back from grep.
1246     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
1247     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
1248     $letter->{'content'} = $message->body_as_string;
1249
1250     return $letter;
1251
1252 }
1253
1254 sub _get_unsent_messages {
1255     my $params = shift;
1256
1257     my $dbh = C4::Context->dbh();
1258     my $statement = << 'ENDSQL';
1259 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
1260   FROM message_queue mq
1261   LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
1262  WHERE status = ?
1263 ENDSQL
1264
1265     my @query_params = ('pending');
1266     if ( ref $params ) {
1267         if ( $params->{'message_transport_type'} ) {
1268             $statement .= ' AND message_transport_type = ? ';
1269             push @query_params, $params->{'message_transport_type'};
1270         }
1271         if ( $params->{'borrowernumber'} ) {
1272             $statement .= ' AND borrowernumber = ? ';
1273             push @query_params, $params->{'borrowernumber'};
1274         }
1275         if ( $params->{'limit'} ) {
1276             $statement .= ' limit ? ';
1277             push @query_params, $params->{'limit'};
1278         }
1279     }
1280
1281     $debug and warn "_get_unsent_messages SQL: $statement";
1282     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
1283     my $sth = $dbh->prepare( $statement );
1284     my $result = $sth->execute( @query_params );
1285     return $sth->fetchall_arrayref({});
1286 }
1287
1288 sub _send_message_by_email {
1289     my $message = shift or return;
1290     my ($username, $password, $method) = @_;
1291
1292     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
1293     my $to_address = $message->{'to_address'};
1294     unless ($to_address) {
1295         unless ($member) {
1296             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
1297             _set_message_status( { message_id => $message->{'message_id'},
1298                                    status     => 'failed' } );
1299             return;
1300         }
1301         $to_address = C4::Members::GetNoticeEmailAddress( $message->{'borrowernumber'} );
1302         unless ($to_address) {
1303             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
1304             # warning too verbose for this more common case?
1305             _set_message_status( { message_id => $message->{'message_id'},
1306                                    status     => 'failed' } );
1307             return;
1308         }
1309     }
1310
1311     my $utf8   = decode('MIME-Header', $message->{'subject'} );
1312     $message->{subject}= encode('MIME-Header', $utf8);
1313     my $subject = encode('UTF-8', $message->{'subject'});
1314     my $content = encode('UTF-8', $message->{'content'});
1315     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
1316     my $is_html = $content_type =~ m/html/io;
1317     my $branch_email = undef;
1318     my $branch_replyto = undef;
1319     my $branch_returnpath = undef;
1320     if ($member) {
1321         my $library = Koha::Libraries->find( $member->{branchcode} );
1322         $branch_email      = $library->branchemail;
1323         $branch_replyto    = $library->branchreplyto;
1324         $branch_returnpath = $library->branchreturnpath;
1325     }
1326     my $email = Koha::Email->new();
1327     my %sendmail_params = $email->create_message_headers(
1328         {
1329             to      => $to_address,
1330             from    => $message->{'from_address'} || $branch_email,
1331             replyto => $branch_replyto,
1332             sender  => $branch_returnpath,
1333             subject => $subject,
1334             message => $is_html ? _wrap_html( $content, $subject ) : $content,
1335             contenttype => $content_type
1336         }
1337     );
1338
1339     $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
1340     if ( my $bcc = C4::Context->preference('OverdueNoticeBcc') ) {
1341        $sendmail_params{ Bcc } = $bcc;
1342     }
1343
1344     _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
1345
1346     if ( sendmail( %sendmail_params ) ) {
1347         _set_message_status( { message_id => $message->{'message_id'},
1348                 status     => 'sent' } );
1349         return 1;
1350     } else {
1351         _set_message_status( { message_id => $message->{'message_id'},
1352                 status     => 'failed' } );
1353         carp $Mail::Sendmail::error;
1354         return;
1355     }
1356 }
1357
1358 sub _wrap_html {
1359     my ($content, $title) = @_;
1360
1361     my $css = C4::Context->preference("NoticeCSS") || '';
1362     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
1363     return <<EOS;
1364 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1365     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1366 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1367 <head>
1368 <title>$title</title>
1369 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1370 $css
1371 </head>
1372 <body>
1373 $content
1374 </body>
1375 </html>
1376 EOS
1377 }
1378
1379 sub _is_duplicate {
1380     my ( $message ) = @_;
1381     my $dbh = C4::Context->dbh;
1382     my $count = $dbh->selectrow_array(q|
1383         SELECT COUNT(*)
1384         FROM message_queue
1385         WHERE message_transport_type = ?
1386         AND borrowernumber = ?
1387         AND letter_code = ?
1388         AND CAST(time_queued AS date) = CAST(NOW() AS date)
1389         AND status="sent"
1390         AND content = ?
1391     |, {}, $message->{message_transport_type}, $message->{borrowernumber}, $message->{letter_code}, $message->{content} );
1392     return $count;
1393 }
1394
1395 sub _send_message_by_sms {
1396     my $message = shift or return;
1397     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
1398
1399     unless ( $member->{smsalertnumber} ) {
1400         _set_message_status( { message_id => $message->{'message_id'},
1401                                status     => 'failed' } );
1402         return;
1403     }
1404
1405     if ( _is_duplicate( $message ) ) {
1406         _set_message_status( { message_id => $message->{'message_id'},
1407                                status     => 'failed' } );
1408         return;
1409     }
1410
1411     my $success = C4::SMS->send_sms( { destination => $member->{'smsalertnumber'},
1412                                        message     => $message->{'content'},
1413                                      } );
1414     _set_message_status( { message_id => $message->{'message_id'},
1415                            status     => ($success ? 'sent' : 'failed') } );
1416     return $success;
1417 }
1418
1419 sub _update_message_to_address {
1420     my ($id, $to)= @_;
1421     my $dbh = C4::Context->dbh();
1422     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1423 }
1424
1425 sub _set_message_status {
1426     my $params = shift or return;
1427
1428     foreach my $required_parameter ( qw( message_id status ) ) {
1429         return unless exists $params->{ $required_parameter };
1430     }
1431
1432     my $dbh = C4::Context->dbh();
1433     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1434     my $sth = $dbh->prepare( $statement );
1435     my $result = $sth->execute( $params->{'status'},
1436                                 $params->{'message_id'} );
1437     return $result;
1438 }
1439
1440 sub _process_tt {
1441     my ( $params ) = @_;
1442
1443     my $content = $params->{content};
1444     my $tables = $params->{tables};
1445     my $loops = $params->{loops};
1446
1447     my $use_template_cache = C4::Context->config('template_cache_dir') && defined $ENV{GATEWAY_INTERFACE};
1448     my $template           = Template->new(
1449         {
1450             EVAL_PERL    => 1,
1451             ABSOLUTE     => 1,
1452             PLUGIN_BASE  => 'Koha::Template::Plugin',
1453             COMPILE_EXT  => $use_template_cache ? '.ttc' : '',
1454             COMPILE_DIR  => $use_template_cache ? C4::Context->config('template_cache_dir') : '',
1455             FILTERS      => {},
1456             ENCODING     => 'UTF-8',
1457         }
1458     ) or die Template->error();
1459
1460     my $tt_params = { %{ _get_tt_params( $tables ) }, %{ _get_tt_params( $loops, 'is_a_loop' ) } };
1461
1462     my $output;
1463     $template->process( \$content, $tt_params, \$output ) || croak "ERROR PROCESSING TEMPLATE: " . $template->error();
1464
1465     return $output;
1466 }
1467
1468 sub _get_tt_params {
1469     my ($tables, $is_a_loop) = @_;
1470
1471     my $params;
1472     $is_a_loop ||= 0;
1473
1474     my $config = {
1475         article_requests => {
1476             module   => 'Koha::ArticleRequests',
1477             singular => 'article_request',
1478             plural   => 'article_requests',
1479             pk       => 'id',
1480           },
1481         biblio => {
1482             module   => 'Koha::Biblios',
1483             singular => 'biblio',
1484             plural   => 'biblios',
1485             pk       => 'biblionumber',
1486         },
1487         borrowers => {
1488             module   => 'Koha::Patrons',
1489             singular => 'borrower',
1490             plural   => 'borrowers',
1491             pk       => 'borrowernumber',
1492         },
1493         branches => {
1494             module   => 'Koha::Libraries',
1495             singular => 'branch',
1496             plural   => 'branches',
1497             pk       => 'branchcode',
1498         },
1499         items => {
1500             module   => 'Koha::Items',
1501             singular => 'item',
1502             plural   => 'items',
1503             pk       => 'itemnumber',
1504         },
1505         opac_news => {
1506             module   => 'Koha::News',
1507             singular => 'news',
1508             plural   => 'news',
1509             pk       => 'idnew',
1510         },
1511         aqorders => {
1512             module   => 'Koha::Tmp::Orders', # Should Koha::Acquisition::Orders when will be based on Koha::Objects
1513             singular => 'order',
1514             plural   => 'orders',
1515             pk       => 'ordernumber',
1516         },
1517         reserves => {
1518             module   => 'Koha::Holds',
1519             singular => 'hold',
1520             plural   => 'holds',
1521             fk       => [ 'borrowernumber', 'biblionumber' ],
1522         },
1523         serial => {
1524             module   => 'Koha::Serials',
1525             singular => 'serial',
1526             plural   => 'serials',
1527             pk       => 'serialid',
1528         },
1529         subscription => {
1530             module   => 'Koha::Subscriptions',
1531             singular => 'subscription',
1532             plural   => 'subscriptions',
1533             pk       => 'subscriptionid',
1534         },
1535         suggestions => {
1536             module   => 'Koha::Suggestions',
1537             singular => 'suggestion',
1538             plural   => 'suggestions',
1539             pk       => 'suggestionid',
1540         },
1541         issues => {
1542             module   => 'Koha::Checkouts',
1543             singular => 'checkout',
1544             plural   => 'checkouts',
1545             fk       => 'itemnumber',
1546         },
1547         borrower_modifications => {
1548             module   => 'Koha::Patron::Modifications',
1549             singular => 'patron_modification',
1550             plural   => 'patron_modifications',
1551             fk       => 'verification_token',
1552         },
1553     };
1554
1555     foreach my $table ( keys %$tables ) {
1556         next unless $config->{$table};
1557
1558         my $ref = ref( $tables->{$table} ) || q{};
1559         my $module = $config->{$table}->{module};
1560
1561         if ( can_load( modules => { $module => undef } ) ) {
1562             my $pk = $config->{$table}->{pk};
1563             my $fk = $config->{$table}->{fk};
1564
1565             if ( $is_a_loop ) {
1566                 my $values = $tables->{$table} || [];
1567                 unless ( ref( $values ) eq 'ARRAY' ) {
1568                     croak "ERROR processing table $table. Wrong API call.";
1569                 }
1570                 my $key = $pk ? $pk : $fk;
1571                 my $objects = $module->search( { $key => { -in => $values } } );
1572                 $params->{ $config->{$table}->{plural} } = $objects;
1573             }
1574             elsif ( $ref eq q{} || $ref eq 'HASH' ) {
1575                 my $id = ref $ref eq 'HASH' ? $tables->{$table}->{$pk} : $tables->{$table};
1576                 my $object;
1577                 if ( $fk ) { # Using a foreign key for lookup
1578                     if ( ref( $fk ) eq 'ARRAY' ) { # Foreign key is multi-column
1579                         my $search;
1580                         foreach my $key ( @$fk ) {
1581                             $search->{$key} = $id->{$key};
1582                         }
1583                         $object = $module->search( $search )->next();
1584                     } else { # Foreign key is single column
1585                         $object = $module->search( { $fk => $id } )->next();
1586                     }
1587                 } else { # using the table's primary key for lookup
1588                     $object = $module->find($id);
1589                 }
1590                 $params->{ $config->{$table}->{singular} } = $object;
1591             }
1592             else {    # $ref eq 'ARRAY'
1593                 my $object;
1594                 if ( @{ $tables->{$table} } == 1 ) {    # Param is a single key
1595                     $object = $module->search( { $pk => $tables->{$table} } )->next();
1596                 }
1597                 else {                                  # Params are mutliple foreign keys
1598                     croak "Multiple foreign keys (table $table) should be passed using an hashref";
1599                 }
1600                 $params->{ $config->{$table}->{singular} } = $object;
1601             }
1602         }
1603         else {
1604             croak "ERROR LOADING MODULE $module: $Module::Load::Conditional::ERROR";
1605         }
1606     }
1607
1608     $params->{today} = dt_from_string();
1609
1610     return $params;
1611 }
1612
1613
1614 1;
1615 __END__