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