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