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