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