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