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