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