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