C4/Letters.pm

   1 package C4::Letters;
   2
   3 # Copyright 2000-2002 Katipo Communications
   4 #
   5 # This file is part of Koha.
   6 #
   7 # Koha is free software; you can redistribute it and/or modify it
   8 # under the terms of the GNU General Public License as published by
   9 # the Free Software Foundation; either version 3 of the License, or
  10 # (at your option) any later version.
  11 #
  12 # Koha is distributed in the hope that it will be useful, but
  13 # WITHOUT ANY WARRANTY; without even the implied warranty of
  14 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  15 # GNU General Public License for more details.
  16 #
  17 # You should have received a copy of the GNU General Public License
  18 # along with Koha; if not, see <http://www.gnu.org/licenses>.
  19
  20 use Modern::Perl;
  21
  22 use MIME::Lite;
  23 use Mail::Sendmail;
  24 use Date::Calc qw( Add_Delta_Days );
  25 use Encode;
  26 use Carp;
  27 use Template;
  28 use Module::Load::Conditional qw(can_load);
  29
  30 use C4::Members;
  31 use C4::Members::Attributes qw(GetBorrowerAttributes);
  32 use C4::Log;
  33 use C4::SMS;
  34 use C4::Debug;
  35 use Koha::DateUtils;
  36 use Koha::SMS::Providers;
  37
  38 use Koha::Email;
  39 use Koha::DateUtils qw( format_sqldatetime dt_from_string );
  40 use Koha::Patrons;
  41
  42 use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  43
  44 BEGIN {
  45     require Exporter;
  46     @ISA = qw(Exporter);
  47     @EXPORT = qw(
  48         &GetLetters &GetLettersAvailableForALibrary &GetLetterTemplates &DelLetter &GetPreparedLetter &GetWrappedLetter &addalert &getalert &delalert &findrelatedto &SendAlerts &GetPrintMessages &GetMessageTransportTypes
  49     );
  50 }
  51
  52 =head1 NAME
  53
  54 C4::Letters - Give functions for Letters management
  55
  56 =head1 SYNOPSIS
  57
  58   use C4::Letters;
  59
  60 =head1 DESCRIPTION
  61
  62   "Letters" is the tool used in Koha to manage informations sent to the patrons and/or the library. This include some cron jobs like
  63   late issues, as well as other tasks like sending a mail to users that have subscribed to a "serial issue alert" (= being warned every time a new issue has arrived at the library)
  64
  65   Letters are managed through "alerts" sent by Koha on some events. All "alert" related functions are in this module too.
  66
  67 =head2 GetLetters([$module])
  68
  69   $letters = &GetLetters($module);
  70   returns informations about letters.
  71   if needed, $module filters for letters given module
  72
  73 =cut
  74
  75 sub GetLetters {
  76     my ($filters) = @_;
  77     my $module    = $filters->{module};
  78     my $code      = $filters->{code};
  79     my $branchcode = $filters->{branchcode};
  80     my $dbh       = C4::Context->dbh;
  81     my $letters   = $dbh->selectall_arrayref(
  82         q|
  83             SELECT module, code, branchcode, name
  84             FROM letter
  85             WHERE 1
  86         |
  87           . ( $module ? q| AND module = ?| : q|| )
  88           . ( $code   ? q| AND code = ?|   : q|| )
  89           . ( defined $branchcode   ? q| AND branchcode = ?|   : q|| )
  90           . q| GROUP BY code ORDER BY name|, { Slice => {} }
  91         , ( $module ? $module : () )
  92         , ( $code ? $code : () )
  93         , ( defined $branchcode ? $branchcode : () )
  94     );
  95
  96     return $letters;
  97 }
  98
  99 =head2 GetLetterTemplates
 100
 101     my $letter_templates = GetLetterTemplates(
 102         {
 103             module => 'circulation',
 104             code => 'my code',
 105             branchcode => 'CPL', # '' for default,
 106         }
 107     );
 108
 109     Return a hashref of letter templates.
 110
 111 =cut
 112
 113 sub GetLetterTemplates {
 114     my ( $params ) = @_;
 115
 116     my $module    = $params->{module};
 117     my $code      = $params->{code};
 118     my $branchcode = $params->{branchcode} // '';
 119     my $dbh       = C4::Context->dbh;
 120     my $letters   = $dbh->selectall_arrayref(
 121         q|
 122             SELECT module, code, branchcode, name, is_html, title, content, message_transport_type, lang
 123             FROM letter
 124             WHERE module = ?
 125             AND code = ?
 126             and branchcode = ?
 127         |
 128         , { Slice => {} }
 129         , $module, $code, $branchcode
 130     );
 131
 132     return $letters;
 133 }
 134
 135 =head2 GetLettersAvailableForALibrary
 136
 137     my $letters = GetLettersAvailableForALibrary(
 138         {
 139             branchcode => 'CPL', # '' for default
 140             module => 'circulation',
 141         }
 142     );
 143
 144     Return an arrayref of letters, sorted by name.
 145     If a specific letter exist for the given branchcode, it will be retrieve.
 146     Otherwise the default letter will be.
 147
 148 =cut
 149
 150 sub GetLettersAvailableForALibrary {
 151     my ($filters)  = @_;
 152     my $branchcode = $filters->{branchcode};
 153     my $module     = $filters->{module};
 154
 155     croak "module should be provided" unless $module;
 156
 157     my $dbh             = C4::Context->dbh;
 158     my $default_letters = $dbh->selectall_arrayref(
 159         q|
 160             SELECT module, code, branchcode, name
 161             FROM letter
 162             WHERE 1
 163         |
 164           . q| AND branchcode = ''|
 165           . ( $module ? q| AND module = ?| : q|| )
 166           . q| ORDER BY name|, { Slice => {} }
 167         , ( $module ? $module : () )
 168     );
 169
 170     my $specific_letters;
 171     if ($branchcode) {
 172         $specific_letters = $dbh->selectall_arrayref(
 173             q|
 174                 SELECT module, code, branchcode, name
 175                 FROM letter
 176                 WHERE 1
 177             |
 178               . q| AND branchcode = ?|
 179               . ( $module ? q| AND module = ?| : q|| )
 180               . q| ORDER BY name|, { Slice => {} }
 181             , $branchcode
 182             , ( $module ? $module : () )
 183         );
 184     }
 185
 186     my %letters;
 187     for my $l (@$default_letters) {
 188         $letters{ $l->{code} } = $l;
 189     }
 190     for my $l (@$specific_letters) {
 191         # Overwrite the default letter with the specific one.
 192         $letters{ $l->{code} } = $l;
 193     }
 194
 195     return [ map { $letters{$_} }
 196           sort { $letters{$a}->{name} cmp $letters{$b}->{name} }
 197           keys %letters ];
 198
 199 }
 200
 201 sub getletter {
 202     my ( $module, $code, $branchcode, $message_transport_type, $lang) = @_;
 203     $message_transport_type //= '%';
 204     $lang = 'default' unless( $lang && C4::Context->preference('TranslateNotices') );
 205
 206
 207     my $only_my_library = C4::Context->only_my_library;
 208     if ( $only_my_library and $branchcode ) {
 209         $branchcode = C4::Context::mybranch();
 210     }
 211     $branchcode //= '';
 212
 213     my $dbh = C4::Context->dbh;
 214     my $sth = $dbh->prepare(q{
 215         SELECT *
 216         FROM letter
 217         WHERE module=? AND code=? AND (branchcode = ? OR branchcode = '')
 218         AND message_transport_type LIKE ?
 219         AND lang =?
 220         ORDER BY branchcode DESC LIMIT 1
 221     });
 222     $sth->execute( $module, $code, $branchcode, $message_transport_type, $lang );
 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 $lang       = $params->{lang};
 253     my $dbh        = C4::Context->dbh;
 254     $dbh->do(q|
 255         DELETE FROM letter
 256         WHERE branchcode = ?
 257           AND module = ?
 258           AND code = ?
 259     |
 260     . ( $mtt ? q| AND message_transport_type = ?| : q|| )
 261     . ( $lang? q| AND lang = ?| : q|| )
 262     , undef, $branchcode, $module, $code, ( $mtt ? $mtt : () ), ( $lang ? $lang : () ) );
 263 }
 264
 265 =head2 addalert ($borrowernumber, $type, $externalid)
 266
 267     parameters :
 268     - $borrowernumber : the number of the borrower subscribing to the alert
 269     - $type : the type of alert.
 270     - $externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid.
 271
 272     create an alert and return the alertid (primary key)
 273
 274 =cut
 275
 276 sub addalert {
 277     my ( $borrowernumber, $type, $externalid ) = @_;
 278     my $dbh = C4::Context->dbh;
 279     my $sth =
 280       $dbh->prepare(
 281         "insert into alert (borrowernumber, type, externalid) values (?,?,?)");
 282     $sth->execute( $borrowernumber, $type, $externalid );
 283
 284     # get the alert number newly created and return it
 285     my $alertid = $dbh->{'mysql_insertid'};
 286     return $alertid;
 287 }
 288
 289 =head2 delalert ($alertid)
 290
 291     parameters :
 292     - alertid : the alert id
 293     deletes the alert
 294
 295 =cut
 296
 297 sub delalert {
 298     my $alertid = shift or die "delalert() called without valid argument (alertid)";    # it's gonna die anyway.
 299     $debug and warn "delalert: deleting alertid $alertid";
 300     my $sth = C4::Context->dbh->prepare("delete from alert where alertid=?");
 301     $sth->execute($alertid);
 302 }
 303
 304 =head2 getalert ([$borrowernumber], [$type], [$externalid])
 305
 306     parameters :
 307     - $borrowernumber : the number of the borrower subscribing to the alert
 308     - $type : the type of alert.
 309     - $externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid.
 310     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.
 311
 312 =cut
 313
 314 sub getalert {
 315     my ( $borrowernumber, $type, $externalid ) = @_;
 316     my $dbh   = C4::Context->dbh;
 317     my $query = "SELECT a.*, b.branchcode FROM alert a JOIN borrowers b USING(borrowernumber) WHERE 1";
 318     my @bind;
 319     if ($borrowernumber and $borrowernumber =~ /^\d+$/) {
 320         $query .= " AND borrowernumber=?";
 321         push @bind, $borrowernumber;
 322     }
 323     if ($type) {
 324         $query .= " AND type=?";
 325         push @bind, $type;
 326     }
 327     if ($externalid) {
 328         $query .= " AND externalid=?";
 329         push @bind, $externalid;
 330     }
 331     my $sth = $dbh->prepare($query);
 332     $sth->execute(@bind);
 333     return $sth->fetchall_arrayref({});
 334 }
 335
 336 =head2 findrelatedto($type, $externalid)
 337
 338     parameters :
 339     - $type : the type of alert
 340     - $externalid : the id of the "object" to query
 341
 342     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.
 343     When type=issue, the id is related to a subscriptionid and this sub returns the name of the biblio.
 344
 345 =cut
 346
 347 # outmoded POD:
 348 # When type=virtual, the id is related to a virtual shelf and this sub returns the name of the sub
 349
 350 sub findrelatedto {
 351     my $type       = shift or return;
 352     my $externalid = shift or return;
 353     my $q = ($type eq 'issue'   ) ?
 354 "select title as result from subscription left join biblio on subscription.biblionumber=biblio.biblionumber where subscriptionid=?" :
 355             ($type eq 'borrower') ?
 356 "select concat(firstname,' ',surname) from borrowers where borrowernumber=?" : undef;
 357     unless ($q) {
 358         warn "findrelatedto(): Illegal type '$type'";
 359         return;
 360     }
 361     my $sth = C4::Context->dbh->prepare($q);
 362     $sth->execute($externalid);
 363     my ($result) = $sth->fetchrow;
 364     return $result;
 365 }
 366
 367 =head2 SendAlerts
 368
 369     my $err = &SendAlerts($type, $externalid, $letter_code);
 370
 371     Parameters:
 372       - $type : the type of alert
 373       - $externalid : the id of the "object" to query
 374       - $letter_code : the notice template to use
 375
 376     C<&SendAlerts> sends an email notice directly to a patron or a vendor.
 377
 378     Currently it supports ($type):
 379       - claim serial issues (claimissues)
 380       - claim acquisition orders (claimacquisition)
 381       - send acquisition orders to the vendor (orderacquisition)
 382       - notify patrons about newly received serial issues (issue)
 383       - notify patrons when their account is created (members)
 384
 385     Returns undef or { error => 'message } on failure.
 386     Returns true on success.
 387
 388 =cut
 389
 390 sub SendAlerts {
 391     my ( $type, $externalid, $letter_code ) = @_;
 392     my $dbh = C4::Context->dbh;
 393     if ( $type eq 'issue' ) {
 394
 395         # prepare the letter...
 396         # search the subscriptionid
 397         my $sth =
 398           $dbh->prepare(
 399             "SELECT subscriptionid FROM serial WHERE serialid=?");
 400         $sth->execute($externalid);
 401         my ($subscriptionid) = $sth->fetchrow
 402           or warn( "No subscription for '$externalid'" ),
 403              return;
 404
 405         # search the biblionumber
 406         $sth =
 407           $dbh->prepare(
 408             "SELECT biblionumber FROM subscription WHERE subscriptionid=?");
 409         $sth->execute($subscriptionid);
 410         my ($biblionumber) = $sth->fetchrow
 411           or warn( "No biblionumber for '$subscriptionid'" ),
 412              return;
 413
 414         my %letter;
 415         # find the list of borrowers to alert
 416         my $alerts = getalert( '', 'issue', $subscriptionid );
 417         foreach (@$alerts) {
 418             my $patron = Koha::Patrons->find( $_->{borrowernumber} );
 419             next unless $patron; # Just in case
 420             my $email = $patron->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'   => $patron->unblessed,
 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             substitute => $substitute,
 786         }
 787     );
 788
 789     $letter->{content} =~ s/<<\S*>>//go; #remove any stragglers
 790
 791     return $letter;
 792 }
 793
 794 sub _substitute_tables {
 795     my ( $letter, $tables ) = @_;
 796     while ( my ($table, $param) = each %$tables ) {
 797         next unless $param;
 798
 799         my $ref = ref $param;
 800
 801         my $values;
 802         if ($ref && $ref eq 'HASH') {
 803             $values = $param;
 804         }
 805         else {
 806             my $sth = _parseletter_sth($table);
 807             unless ($sth) {
 808                 warn "_parseletter_sth('$table') failed to return a valid sth.  No substitution will be done for that table.";
 809                 return;
 810             }
 811             $sth->execute( $ref ? @$param : $param );
 812
 813             $values = $sth->fetchrow_hashref;
 814             $sth->finish();
 815         }
 816
 817         _parseletter ( $letter, $table, $values );
 818     }
 819 }
 820
 821 sub _parseletter_sth {
 822     my $table = shift;
 823     my $sth;
 824     unless ($table) {
 825         carp "ERROR: _parseletter_sth() called without argument (table)";
 826         return;
 827     }
 828     # NOTE: we used to check whether we had a statement handle cached in
 829     #       a %handles module-level variable. This was a dumb move and
 830     #       broke things for the rest of us. prepare_cached is a better
 831     #       way to cache statement handles anyway.
 832     my $query =
 833     ($table eq 'biblio'       )    ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 834     ($table eq 'biblioitems'  )    ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 835     ($table eq 'items'        )    ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 836     ($table eq 'issues'       )    ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 837     ($table eq 'old_issues'   )    ? "SELECT * FROM $table WHERE     itemnumber = ? ORDER BY timestamp DESC LIMIT 1"  :
 838     ($table eq 'reserves'     )    ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?"             :
 839     ($table eq 'borrowers'    )    ? "SELECT * FROM $table WHERE borrowernumber = ?"                                  :
 840     ($table eq 'branches'     )    ? "SELECT * FROM $table WHERE     branchcode = ?"                                  :
 841     ($table eq 'suggestions'  )    ? "SELECT * FROM $table WHERE   suggestionid = ?"                                  :
 842     ($table eq 'aqbooksellers')    ? "SELECT * FROM $table WHERE             id = ?"                                  :
 843     ($table eq 'aqorders'     )    ? "SELECT * FROM $table WHERE    ordernumber = ?"                                  :
 844     ($table eq 'opac_news'    )    ? "SELECT * FROM $table WHERE          idnew = ?"                                  :
 845     ($table eq 'article_requests') ? "SELECT * FROM $table WHERE             id = ?"                                  :
 846     ($table eq 'borrower_modifications') ? "SELECT * FROM $table WHERE verification_token = ?" :
 847     ($table eq 'subscription') ? "SELECT * FROM $table WHERE subscriptionid = ?" :
 848     ($table eq 'serial') ? "SELECT * FROM $table WHERE serialid = ?" :
 849     undef ;
 850     unless ($query) {
 851         warn "ERROR: No _parseletter_sth query for table '$table'";
 852         return;     # nothing to get
 853     }
 854     unless ($sth = C4::Context->dbh->prepare_cached($query)) {
 855         warn "ERROR: Failed to prepare query: '$query'";
 856         return;
 857     }
 858     return $sth;    # now cache is populated for that $table
 859 }
 860
 861 =head2 _parseletter($letter, $table, $values)
 862
 863     parameters :
 864     - $letter : a hash to letter fields (title & content useful)
 865     - $table : the Koha table to parse.
 866     - $values_in : table record hashref
 867     parse all fields from a table, and replace values in title & content with the appropriate value
 868     (not exported sub, used only internally)
 869
 870 =cut
 871
 872 sub _parseletter {
 873     my ( $letter, $table, $values_in ) = @_;
 874
 875     # Work on a local copy of $values_in (passed by reference) to avoid side effects
 876     # in callers ( by changing / formatting values )
 877     my $values = $values_in ? { %$values_in } : {};
 878
 879     if ( $table eq 'borrowers' && $values->{'dateexpiry'} ){
 880         $values->{'dateexpiry'} = format_sqldatetime( $values->{'dateexpiry'} );
 881     }
 882
 883     if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
 884         $values->{'waitingdate'} = output_pref({ dt => dt_from_string( $values->{'waitingdate'} ), dateonly => 1 });
 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, limit => 50 });
1027
1028 Sends all of the 'pending' items in the message queue, unless the optional
1029 limit parameter is passed too. The verbose parameter is also optional.
1030
1031 Returns number of messages sent.
1032
1033 =cut
1034
1035 sub SendQueuedMessages {
1036     my $params = shift;
1037
1038     my $unsent_messages = _get_unsent_messages( { limit => $params->{limit} } );
1039     MESSAGE: foreach my $message ( @$unsent_messages ) {
1040         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
1041         warn sprintf( 'sending %s message to patron: %s',
1042                       $message->{'message_transport_type'},
1043                       $message->{'borrowernumber'} || 'Admin' )
1044           if $params->{'verbose'} or $debug;
1045         # This is just begging for subclassing
1046         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
1047         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
1048             _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
1049         }
1050         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
1051             if ( C4::Context->preference('SMSSendDriver') eq 'Email' ) {
1052                 my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1053                 my $sms_provider = Koha::SMS::Providers->find( $patron->sms_provider_id );
1054                 unless ( $sms_provider ) {
1055                     warn sprintf( "Patron %s has no sms provider id set!", $message->{'borrowernumber'} ) if $params->{'verbose'} or $debug;
1056                     _set_message_status( { message_id => $message->{'message_id'}, status => 'failed' } );
1057                     next MESSAGE;
1058                 }
1059                 $message->{to_address} ||= $patron->smsalertnumber;
1060                 unless ( $message->{to_address} && $patron->smsalertnumber ) {
1061                     _set_message_status( { message_id => $message->{'message_id'}, status => 'failed' } );
1062                     warn sprintf( "No smsalertnumber found for patron %s!", $message->{'borrowernumber'} ) if $params->{'verbose'} or $debug;
1063                     next MESSAGE;
1064                 }
1065                 $message->{to_address} .= '@' . $sms_provider->domain();
1066                 _update_message_to_address($message->{'message_id'},$message->{to_address});
1067                 _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
1068             } else {
1069                 _send_message_by_sms( $message );
1070             }
1071         }
1072     }
1073     return scalar( @$unsent_messages );
1074 }
1075
1076 =head2 GetRSSMessages
1077
1078   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
1079
1080 returns a listref of all queued RSS messages for a particular person.
1081
1082 =cut
1083
1084 sub GetRSSMessages {
1085     my $params = shift;
1086
1087     return unless $params;
1088     return unless ref $params;
1089     return unless $params->{'borrowernumber'};
1090
1091     return _get_unsent_messages( { message_transport_type => 'rss',
1092                                    limit                  => $params->{'limit'},
1093                                    borrowernumber         => $params->{'borrowernumber'}, } );
1094 }
1095
1096 =head2 GetPrintMessages
1097
1098   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
1099
1100 Returns a arrayref of all queued print messages (optionally, for a particular
1101 person).
1102
1103 =cut
1104
1105 sub GetPrintMessages {
1106     my $params = shift || {};
1107
1108     return _get_unsent_messages( { message_transport_type => 'print',
1109                                    borrowernumber         => $params->{'borrowernumber'},
1110                                  } );
1111 }
1112
1113 =head2 GetQueuedMessages ([$hashref])
1114
1115   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
1116
1117 fetches messages out of the message queue.
1118
1119 returns:
1120 list of hashes, each has represents a message in the message queue.
1121
1122 =cut
1123
1124 sub GetQueuedMessages {
1125     my $params = shift;
1126
1127     my $dbh = C4::Context->dbh();
1128     my $statement = << 'ENDSQL';
1129 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued
1130 FROM message_queue
1131 ENDSQL
1132
1133     my @query_params;
1134     my @whereclauses;
1135     if ( exists $params->{'borrowernumber'} ) {
1136         push @whereclauses, ' borrowernumber = ? ';
1137         push @query_params, $params->{'borrowernumber'};
1138     }
1139
1140     if ( @whereclauses ) {
1141         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
1142     }
1143
1144     if ( defined $params->{'limit'} ) {
1145         $statement .= ' LIMIT ? ';
1146         push @query_params, $params->{'limit'};
1147     }
1148
1149     my $sth = $dbh->prepare( $statement );
1150     my $result = $sth->execute( @query_params );
1151     return $sth->fetchall_arrayref({});
1152 }
1153
1154 =head2 GetMessageTransportTypes
1155
1156   my @mtt = GetMessageTransportTypes();
1157
1158   returns an arrayref of transport types
1159
1160 =cut
1161
1162 sub GetMessageTransportTypes {
1163     my $dbh = C4::Context->dbh();
1164     my $mtts = $dbh->selectcol_arrayref("
1165         SELECT message_transport_type
1166         FROM message_transport_types
1167         ORDER BY message_transport_type
1168     ");
1169     return $mtts;
1170 }
1171
1172 =head2 GetMessage
1173
1174     my $message = C4::Letters::Message($message_id);
1175
1176 =cut
1177
1178 sub GetMessage {
1179     my ( $message_id ) = @_;
1180     return unless $message_id;
1181     my $dbh = C4::Context->dbh;
1182     return $dbh->selectrow_hashref(q|
1183         SELECT message_id, borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type
1184         FROM message_queue
1185         WHERE message_id = ?
1186     |, {}, $message_id );
1187 }
1188
1189 =head2 ResendMessage
1190
1191   Attempt to resend a message which has failed previously.
1192
1193   my $has_been_resent = C4::Letters::ResendMessage($message_id);
1194
1195   Updates the message to 'pending' status so that
1196   it will be resent later on.
1197
1198   returns 1 on success, 0 on failure, undef if no message was found
1199
1200 =cut
1201
1202 sub ResendMessage {
1203     my $message_id = shift;
1204     return unless $message_id;
1205
1206     my $message = GetMessage( $message_id );
1207     return unless $message;
1208     my $rv = 0;
1209     if ( $message->{status} ne 'pending' ) {
1210         $rv = C4::Letters::_set_message_status({
1211             message_id => $message_id,
1212             status => 'pending',
1213         });
1214         $rv = $rv > 0? 1: 0;
1215         # Clear destination email address to force address update
1216         _update_message_to_address( $message_id, undef ) if $rv &&
1217             $message->{message_transport_type} eq 'email';
1218     }
1219     return $rv;
1220 }
1221
1222 =head2 _add_attachements
1223
1224 named parameters:
1225 letter - the standard letter hashref
1226 attachments - listref of attachments. each attachment is a hashref of:
1227   type - the mime type, like 'text/plain'
1228   content - the actual attachment
1229   filename - the name of the attachment.
1230 message - a MIME::Lite object to attach these to.
1231
1232 returns your letter object, with the content updated.
1233
1234 =cut
1235
1236 sub _add_attachments {
1237     my $params = shift;
1238
1239     my $letter = $params->{'letter'};
1240     my $attachments = $params->{'attachments'};
1241     return $letter unless @$attachments;
1242     my $message = $params->{'message'};
1243
1244     # First, we have to put the body in as the first attachment
1245     $message->attach(
1246         Type => $letter->{'content-type'} || 'TEXT',
1247         Data => $letter->{'is_html'}
1248             ? _wrap_html($letter->{'content'}, $letter->{'title'})
1249             : $letter->{'content'},
1250     );
1251
1252     foreach my $attachment ( @$attachments ) {
1253         $message->attach(
1254             Type     => $attachment->{'type'},
1255             Data     => $attachment->{'content'},
1256             Filename => $attachment->{'filename'},
1257         );
1258     }
1259     # we're forcing list context here to get the header, not the count back from grep.
1260     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
1261     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
1262     $letter->{'content'} = $message->body_as_string;
1263
1264     return $letter;
1265
1266 }
1267
1268 sub _get_unsent_messages {
1269     my $params = shift;
1270
1271     my $dbh = C4::Context->dbh();
1272     my $statement = qq{
1273         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
1274         FROM message_queue mq
1275         LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
1276         WHERE status = ?
1277     };
1278
1279     my @query_params = ('pending');
1280     if ( ref $params ) {
1281         if ( $params->{'message_transport_type'} ) {
1282             $statement .= ' AND message_transport_type = ? ';
1283             push @query_params, $params->{'message_transport_type'};
1284         }
1285         if ( $params->{'borrowernumber'} ) {
1286             $statement .= ' AND borrowernumber = ? ';
1287             push @query_params, $params->{'borrowernumber'};
1288         }
1289         if ( $params->{'limit'} ) {
1290             $statement .= ' limit ? ';
1291             push @query_params, $params->{'limit'};
1292         }
1293     }
1294
1295     $debug and warn "_get_unsent_messages SQL: $statement";
1296     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
1297     my $sth = $dbh->prepare( $statement );
1298     my $result = $sth->execute( @query_params );
1299     return $sth->fetchall_arrayref({});
1300 }
1301
1302 sub _send_message_by_email {
1303     my $message = shift or return;
1304     my ($username, $password, $method) = @_;
1305
1306     my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1307     my $to_address = $message->{'to_address'};
1308     unless ($to_address) {
1309         unless ($patron) {
1310             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
1311             _set_message_status( { message_id => $message->{'message_id'},
1312                                    status     => 'failed' } );
1313             return;
1314         }
1315         $to_address = C4::Members::GetNoticeEmailAddress( $message->{'borrowernumber'} );
1316         unless ($to_address) {
1317             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
1318             # warning too verbose for this more common case?
1319             _set_message_status( { message_id => $message->{'message_id'},
1320                                    status     => 'failed' } );
1321             return;
1322         }
1323     }
1324
1325     my $utf8   = decode('MIME-Header', $message->{'subject'} );
1326     $message->{subject}= encode('MIME-Header', $utf8);
1327     my $subject = encode('UTF-8', $message->{'subject'});
1328     my $content = encode('UTF-8', $message->{'content'});
1329     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
1330     my $is_html = $content_type =~ m/html/io;
1331     my $branch_email = undef;
1332     my $branch_replyto = undef;
1333     my $branch_returnpath = undef;
1334     if ($patron) {
1335         my $library = $patron->library;
1336         $branch_email      = $library->branchemail;
1337         $branch_replyto    = $library->branchreplyto;
1338         $branch_returnpath = $library->branchreturnpath;
1339     }
1340     my $email = Koha::Email->new();
1341     my %sendmail_params = $email->create_message_headers(
1342         {
1343             to      => $to_address,
1344             from    => $message->{'from_address'} || $branch_email,
1345             replyto => $branch_replyto,
1346             sender  => $branch_returnpath,
1347             subject => $subject,
1348             message => $is_html ? _wrap_html( $content, $subject ) : $content,
1349             contenttype => $content_type
1350         }
1351     );
1352
1353     $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
1354     if ( my $bcc = C4::Context->preference('NoticeBcc') ) {
1355        $sendmail_params{ Bcc } = $bcc;
1356     }
1357
1358     _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
1359
1360     if ( sendmail( %sendmail_params ) ) {
1361         _set_message_status( { message_id => $message->{'message_id'},
1362                 status     => 'sent' } );
1363         return 1;
1364     } else {
1365         _set_message_status( { message_id => $message->{'message_id'},
1366                 status     => 'failed' } );
1367         carp $Mail::Sendmail::error;
1368         return;
1369     }
1370 }
1371
1372 sub _wrap_html {
1373     my ($content, $title) = @_;
1374
1375     my $css = C4::Context->preference("NoticeCSS") || '';
1376     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
1377     return <<EOS;
1378 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1379     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1380 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1381 <head>
1382 <title>$title</title>
1383 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1384 $css
1385 </head>
1386 <body>
1387 $content
1388 </body>
1389 </html>
1390 EOS
1391 }
1392
1393 sub _is_duplicate {
1394     my ( $message ) = @_;
1395     my $dbh = C4::Context->dbh;
1396     my $count = $dbh->selectrow_array(q|
1397         SELECT COUNT(*)
1398         FROM message_queue
1399         WHERE message_transport_type = ?
1400         AND borrowernumber = ?
1401         AND letter_code = ?
1402         AND CAST(time_queued AS date) = CAST(NOW() AS date)
1403         AND status="sent"
1404         AND content = ?
1405     |, {}, $message->{message_transport_type}, $message->{borrowernumber}, $message->{letter_code}, $message->{content} );
1406     return $count;
1407 }
1408
1409 sub _send_message_by_sms {
1410     my $message = shift or return;
1411     my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1412
1413     unless ( $patron and $patron->smsalertnumber ) {
1414         _set_message_status( { message_id => $message->{'message_id'},
1415                                status     => 'failed' } );
1416         return;
1417     }
1418
1419     if ( _is_duplicate( $message ) ) {
1420         _set_message_status( { message_id => $message->{'message_id'},
1421                                status     => 'failed' } );
1422         return;
1423     }
1424
1425     my $success = C4::SMS->send_sms( { destination => $patron->smsalertnumber,
1426                                        message     => $message->{'content'},
1427                                      } );
1428     _set_message_status( { message_id => $message->{'message_id'},
1429                            status     => ($success ? 'sent' : 'failed') } );
1430     return $success;
1431 }
1432
1433 sub _update_message_to_address {
1434     my ($id, $to)= @_;
1435     my $dbh = C4::Context->dbh();
1436     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1437 }
1438
1439 sub _set_message_status {
1440     my $params = shift or return;
1441
1442     foreach my $required_parameter ( qw( message_id status ) ) {
1443         return unless exists $params->{ $required_parameter };
1444     }
1445
1446     my $dbh = C4::Context->dbh();
1447     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1448     my $sth = $dbh->prepare( $statement );
1449     my $result = $sth->execute( $params->{'status'},
1450                                 $params->{'message_id'} );
1451     return $result;
1452 }
1453
1454 sub _process_tt {
1455     my ( $params ) = @_;
1456
1457     my $content = $params->{content};
1458     my $tables = $params->{tables};
1459     my $loops = $params->{loops};
1460     my $substitute = $params->{substitute} || {};
1461
1462     my $use_template_cache = C4::Context->config('template_cache_dir') && defined $ENV{GATEWAY_INTERFACE};
1463     my $template           = Template->new(
1464         {
1465             EVAL_PERL    => 1,
1466             ABSOLUTE     => 1,
1467             PLUGIN_BASE  => 'Koha::Template::Plugin',
1468             COMPILE_EXT  => $use_template_cache ? '.ttc' : '',
1469             COMPILE_DIR  => $use_template_cache ? C4::Context->config('template_cache_dir') : '',
1470             FILTERS      => {},
1471             ENCODING     => 'UTF-8',
1472         }
1473     ) or die Template->error();
1474
1475     my $tt_params = { %{ _get_tt_params( $tables ) }, %{ _get_tt_params( $loops, 'is_a_loop' ) }, %$substitute };
1476
1477     $content = qq|[% USE KohaDates %]$content|;
1478
1479     my $output;
1480     $template->process( \$content, $tt_params, \$output ) || croak "ERROR PROCESSING TEMPLATE: " . $template->error();
1481
1482     return $output;
1483 }
1484
1485 sub _get_tt_params {
1486     my ($tables, $is_a_loop) = @_;
1487
1488     my $params;
1489     $is_a_loop ||= 0;
1490
1491     my $config = {
1492         article_requests => {
1493             module   => 'Koha::ArticleRequests',
1494             singular => 'article_request',
1495             plural   => 'article_requests',
1496             pk       => 'id',
1497           },
1498         biblio => {
1499             module   => 'Koha::Biblios',
1500             singular => 'biblio',
1501             plural   => 'biblios',
1502             pk       => 'biblionumber',
1503         },
1504         borrowers => {
1505             module   => 'Koha::Patrons',
1506             singular => 'borrower',
1507             plural   => 'borrowers',
1508             pk       => 'borrowernumber',
1509         },
1510         branches => {
1511             module   => 'Koha::Libraries',
1512             singular => 'branch',
1513             plural   => 'branches',
1514             pk       => 'branchcode',
1515         },
1516         items => {
1517             module   => 'Koha::Items',
1518             singular => 'item',
1519             plural   => 'items',
1520             pk       => 'itemnumber',
1521         },
1522         opac_news => {
1523             module   => 'Koha::News',
1524             singular => 'news',
1525             plural   => 'news',
1526             pk       => 'idnew',
1527         },
1528         aqorders => {
1529             module   => 'Koha::Acquisition::Orders',
1530             singular => 'order',
1531             plural   => 'orders',
1532             pk       => 'ordernumber',
1533         },
1534         reserves => {
1535             module   => 'Koha::Holds',
1536             singular => 'hold',
1537             plural   => 'holds',
1538             fk       => [ 'borrowernumber', 'biblionumber' ],
1539         },
1540         serial => {
1541             module   => 'Koha::Serials',
1542             singular => 'serial',
1543             plural   => 'serials',
1544             pk       => 'serialid',
1545         },
1546         subscription => {
1547             module   => 'Koha::Subscriptions',
1548             singular => 'subscription',
1549             plural   => 'subscriptions',
1550             pk       => 'subscriptionid',
1551         },
1552         suggestions => {
1553             module   => 'Koha::Suggestions',
1554             singular => 'suggestion',
1555             plural   => 'suggestions',
1556             pk       => 'suggestionid',
1557         },
1558         issues => {
1559             module   => 'Koha::Checkouts',
1560             singular => 'checkout',
1561             plural   => 'checkouts',
1562             fk       => 'itemnumber',
1563         },
1564         old_issues => {
1565             module   => 'Koha::Old::Checkouts',
1566             singular => 'old_checkout',
1567             plural   => 'old_checkouts',
1568             fk       => 'itemnumber',
1569         },
1570         overdues => {
1571             module   => 'Koha::Checkouts',
1572             singular => 'overdue',
1573             plural   => 'overdues',
1574             fk       => 'itemnumber',
1575         },
1576         borrower_modifications => {
1577             module   => 'Koha::Patron::Modifications',
1578             singular => 'patron_modification',
1579             plural   => 'patron_modifications',
1580             fk       => 'verification_token',
1581         },
1582     };
1583
1584     foreach my $table ( keys %$tables ) {
1585         next unless $config->{$table};
1586
1587         my $ref = ref( $tables->{$table} ) || q{};
1588         my $module = $config->{$table}->{module};
1589
1590         if ( can_load( modules => { $module => undef } ) ) {
1591             my $pk = $config->{$table}->{pk};
1592             my $fk = $config->{$table}->{fk};
1593
1594             if ( $is_a_loop ) {
1595                 my $values = $tables->{$table} || [];
1596                 unless ( ref( $values ) eq 'ARRAY' ) {
1597                     croak "ERROR processing table $table. Wrong API call.";
1598                 }
1599                 my $key = $pk ? $pk : $fk;
1600                 # $key does not come from user input
1601                 my $objects = $module->search(
1602                     { $key => $values },
1603                     {
1604                             # We want to retrieve the data in the same order
1605                             # FIXME MySQLism
1606                             # field is a MySQLism, but they are no other way to do it
1607                             # To be generic we could do it in perl, but we will need to fetch
1608                             # all the data then order them
1609                         @$values ? ( order_by => \[ "field($key, " . join( ', ', @$values ) . ")" ] ) : ()
1610                     }
1611                 );
1612                 $params->{ $config->{$table}->{plural} } = $objects;
1613             }
1614             elsif ( $ref eq q{} || $ref eq 'HASH' ) {
1615                 my $id = ref $ref eq 'HASH' ? $tables->{$table}->{$pk} : $tables->{$table};
1616                 my $object;
1617                 if ( $fk ) { # Using a foreign key for lookup
1618                     if ( ref( $fk ) eq 'ARRAY' ) { # Foreign key is multi-column
1619                         my $search;
1620                         foreach my $key ( @$fk ) {
1621                             $search->{$key} = $id->{$key};
1622                         }
1623                         $object = $module->search( $search )->last();
1624                     } else { # Foreign key is single column
1625                         $object = $module->search( { $fk => $id } )->last();
1626                     }
1627                 } else { # using the table's primary key for lookup
1628                     $object = $module->find($id);
1629                 }
1630                 $params->{ $config->{$table}->{singular} } = $object;
1631             }
1632             else {    # $ref eq 'ARRAY'
1633                 my $object;
1634                 if ( @{ $tables->{$table} } == 1 ) {    # Param is a single key
1635                     $object = $module->search( { $pk => $tables->{$table} } )->last();
1636                 }
1637                 else {                                  # Params are mutliple foreign keys
1638                     croak "Multiple foreign keys (table $table) should be passed using an hashref";
1639                 }
1640                 $params->{ $config->{$table}->{singular} } = $object;
1641             }
1642         }
1643         else {
1644             croak "ERROR LOADING MODULE $module: $Module::Load::Conditional::ERROR";
1645         }
1646     }
1647
1648     $params->{today} = output_pref({ dt => dt_from_string, dateformat => 'iso' });
1649
1650     return $params;
1651 }
1652
1653 =head2 get_item_content
1654
1655     my $item = Koha::Items->find(...)->unblessed;
1656     my @item_content_fields = qw( date_due title barcode author itemnumber );
1657     my $item_content = C4::Letters::get_item_content({
1658                              item => $item,
1659                              item_content_fields => \@item_content_fields
1660                        });
1661
1662 This function generates a tab-separated list of values for the passed item. Dates
1663 are formatted following the current setup.
1664
1665 =cut
1666
1667 sub get_item_content {
1668     my ( $params ) = @_;
1669     my $item = $params->{item};
1670     my $dateonly = $params->{dateonly} || 0;
1671     my $item_content_fields = $params->{item_content_fields} || [];
1672
1673     return unless $item;
1674
1675     my @item_info = map {
1676         $_ =~ /^date|date$/
1677           ? eval {
1678             output_pref(
1679                 { dt => dt_from_string( $item->{$_} ), dateonly => $dateonly } );
1680           }
1681           : $item->{$_}
1682           || ''
1683     } @$item_content_fields;
1684     return join( "\t", @item_info ) . "\n";
1685 }
1686
1687 1;
1688 __END__