C4/Letters.pm

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