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( Mail::Sendmail::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 ( Mail::Sendmail::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( Mail::Sendmail::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({
1027         letter_code => $letter_code,
1028         borrowernumber => $who_letter_is_for,
1029         limit => 50,
1030         verbose => 1,
1031         type => 'sms',
1032     });
1033
1034 Sends all of the 'pending' items in the message queue, unless
1035 parameters are passed.
1036
1037 The letter_code, borrowernumber and limit parameters are used
1038 to build a parameter set for _get_unsent_messages, thus limiting
1039 which pending messages will be processed. They are all optional.
1040
1041 The verbose parameter can be used to generate debugging output.
1042 It is also optional.
1043
1044 Returns number of messages sent.
1045
1046 =cut
1047
1048 sub SendQueuedMessages {
1049     my $params = shift;
1050
1051     my $which_unsent_messages  = {
1052         'limit'          => $params->{'limit'} // 0,
1053         'borrowernumber' => $params->{'borrowernumber'} // q{},
1054         'letter_code'    => $params->{'letter_code'} // q{},
1055         'type'           => $params->{'type'} // q{},
1056     };
1057     my $unsent_messages = _get_unsent_messages( $which_unsent_messages );
1058     MESSAGE: foreach my $message ( @$unsent_messages ) {
1059         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
1060         warn sprintf( 'sending %s message to patron: %s',
1061                       $message->{'message_transport_type'},
1062                       $message->{'borrowernumber'} || 'Admin' )
1063           if $params->{'verbose'} or $debug;
1064         # This is just begging for subclassing
1065         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
1066         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
1067             _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
1068         }
1069         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
1070             if ( C4::Context->preference('SMSSendDriver') eq 'Email' ) {
1071                 my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1072                 my $sms_provider = Koha::SMS::Providers->find( $patron->sms_provider_id );
1073                 unless ( $sms_provider ) {
1074                     warn sprintf( "Patron %s has no sms provider id set!", $message->{'borrowernumber'} ) if $params->{'verbose'} or $debug;
1075                     _set_message_status( { message_id => $message->{'message_id'}, status => 'failed' } );
1076                     next MESSAGE;
1077                 }
1078                 unless ( $patron->smsalertnumber ) {
1079                     _set_message_status( { message_id => $message->{'message_id'}, status => 'failed' } );
1080                     warn sprintf( "No smsalertnumber found for patron %s!", $message->{'borrowernumber'} ) if $params->{'verbose'} or $debug;
1081                     next MESSAGE;
1082                 }
1083                 $message->{to_address}  = $patron->smsalertnumber; #Sometime this is set to email - sms should always use smsalertnumber
1084                 $message->{to_address} .= '@' . $sms_provider->domain();
1085                 _update_message_to_address($message->{'message_id'},$message->{to_address});
1086                 _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
1087             } else {
1088                 _send_message_by_sms( $message );
1089             }
1090         }
1091     }
1092     return scalar( @$unsent_messages );
1093 }
1094
1095 =head2 GetRSSMessages
1096
1097   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
1098
1099 returns a listref of all queued RSS messages for a particular person.
1100
1101 =cut
1102
1103 sub GetRSSMessages {
1104     my $params = shift;
1105
1106     return unless $params;
1107     return unless ref $params;
1108     return unless $params->{'borrowernumber'};
1109
1110     return _get_unsent_messages( { message_transport_type => 'rss',
1111                                    limit                  => $params->{'limit'},
1112                                    borrowernumber         => $params->{'borrowernumber'}, } );
1113 }
1114
1115 =head2 GetPrintMessages
1116
1117   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
1118
1119 Returns a arrayref of all queued print messages (optionally, for a particular
1120 person).
1121
1122 =cut
1123
1124 sub GetPrintMessages {
1125     my $params = shift || {};
1126
1127     return _get_unsent_messages( { message_transport_type => 'print',
1128                                    borrowernumber         => $params->{'borrowernumber'},
1129                                  } );
1130 }
1131
1132 =head2 GetQueuedMessages ([$hashref])
1133
1134   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
1135
1136 fetches messages out of the message queue.
1137
1138 returns:
1139 list of hashes, each has represents a message in the message queue.
1140
1141 =cut
1142
1143 sub GetQueuedMessages {
1144     my $params = shift;
1145
1146     my $dbh = C4::Context->dbh();
1147     my $statement = << 'ENDSQL';
1148 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued
1149 FROM message_queue
1150 ENDSQL
1151
1152     my @query_params;
1153     my @whereclauses;
1154     if ( exists $params->{'borrowernumber'} ) {
1155         push @whereclauses, ' borrowernumber = ? ';
1156         push @query_params, $params->{'borrowernumber'};
1157     }
1158
1159     if ( @whereclauses ) {
1160         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
1161     }
1162
1163     if ( defined $params->{'limit'} ) {
1164         $statement .= ' LIMIT ? ';
1165         push @query_params, $params->{'limit'};
1166     }
1167
1168     my $sth = $dbh->prepare( $statement );
1169     my $result = $sth->execute( @query_params );
1170     return $sth->fetchall_arrayref({});
1171 }
1172
1173 =head2 GetMessageTransportTypes
1174
1175   my @mtt = GetMessageTransportTypes();
1176
1177   returns an arrayref of transport types
1178
1179 =cut
1180
1181 sub GetMessageTransportTypes {
1182     my $dbh = C4::Context->dbh();
1183     my $mtts = $dbh->selectcol_arrayref("
1184         SELECT message_transport_type
1185         FROM message_transport_types
1186         ORDER BY message_transport_type
1187     ");
1188     return $mtts;
1189 }
1190
1191 =head2 GetMessage
1192
1193     my $message = C4::Letters::Message($message_id);
1194
1195 =cut
1196
1197 sub GetMessage {
1198     my ( $message_id ) = @_;
1199     return unless $message_id;
1200     my $dbh = C4::Context->dbh;
1201     return $dbh->selectrow_hashref(q|
1202         SELECT message_id, borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type
1203         FROM message_queue
1204         WHERE message_id = ?
1205     |, {}, $message_id );
1206 }
1207
1208 =head2 ResendMessage
1209
1210   Attempt to resend a message which has failed previously.
1211
1212   my $has_been_resent = C4::Letters::ResendMessage($message_id);
1213
1214   Updates the message to 'pending' status so that
1215   it will be resent later on.
1216
1217   returns 1 on success, 0 on failure, undef if no message was found
1218
1219 =cut
1220
1221 sub ResendMessage {
1222     my $message_id = shift;
1223     return unless $message_id;
1224
1225     my $message = GetMessage( $message_id );
1226     return unless $message;
1227     my $rv = 0;
1228     if ( $message->{status} ne 'pending' ) {
1229         $rv = C4::Letters::_set_message_status({
1230             message_id => $message_id,
1231             status => 'pending',
1232         });
1233         $rv = $rv > 0? 1: 0;
1234         # Clear destination email address to force address update
1235         _update_message_to_address( $message_id, undef ) if $rv &&
1236             $message->{message_transport_type} eq 'email';
1237     }
1238     return $rv;
1239 }
1240
1241 =head2 _add_attachements
1242
1243   named parameters:
1244   letter - the standard letter hashref
1245   attachments - listref of attachments. each attachment is a hashref of:
1246     type - the mime type, like 'text/plain'
1247     content - the actual attachment
1248     filename - the name of the attachment.
1249   message - a MIME::Lite object to attach these to.
1250
1251   returns your letter object, with the content updated.
1252
1253 =cut
1254
1255 sub _add_attachments {
1256     my $params = shift;
1257
1258     my $letter = $params->{'letter'};
1259     my $attachments = $params->{'attachments'};
1260     return $letter unless @$attachments;
1261     my $message = $params->{'message'};
1262
1263     # First, we have to put the body in as the first attachment
1264     $message->attach(
1265         Type => $letter->{'content-type'} || 'TEXT',
1266         Data => $letter->{'is_html'}
1267             ? _wrap_html($letter->{'content'}, $letter->{'title'})
1268             : $letter->{'content'},
1269     );
1270
1271     foreach my $attachment ( @$attachments ) {
1272         $message->attach(
1273             Type     => $attachment->{'type'},
1274             Data     => $attachment->{'content'},
1275             Filename => $attachment->{'filename'},
1276         );
1277     }
1278     # we're forcing list context here to get the header, not the count back from grep.
1279     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
1280     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
1281     $letter->{'content'} = $message->body_as_string;
1282
1283     return $letter;
1284
1285 }
1286
1287 =head2 _get_unsent_messages
1288
1289   This function's parameter hash reference takes the following
1290   optional named parameters:
1291    message_transport_type: method of message sending (e.g. email, sms, etc.)
1292    borrowernumber        : who the message is to be sent
1293    letter_code           : type of message being sent (e.g. PASSWORD_RESET)
1294    limit                 : maximum number of messages to send
1295
1296   This function returns an array of matching hash referenced rows from
1297   message_queue with some borrower information added.
1298
1299 =cut
1300
1301 sub _get_unsent_messages {
1302     my $params = shift;
1303
1304     my $dbh = C4::Context->dbh();
1305     my $statement = qq{
1306         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
1307         FROM message_queue mq
1308         LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
1309         WHERE status = ?
1310     };
1311
1312     my @query_params = ('pending');
1313     if ( ref $params ) {
1314         if ( $params->{'message_transport_type'} ) {
1315             $statement .= ' AND mq.message_transport_type = ? ';
1316             push @query_params, $params->{'message_transport_type'};
1317         }
1318         if ( $params->{'borrowernumber'} ) {
1319             $statement .= ' AND mq.borrowernumber = ? ';
1320             push @query_params, $params->{'borrowernumber'};
1321         }
1322         if ( $params->{'letter_code'} ) {
1323             $statement .= ' AND mq.letter_code = ? ';
1324             push @query_params, $params->{'letter_code'};
1325         }
1326         if ( $params->{'type'} ) {
1327             $statement .= ' AND message_transport_type = ? ';
1328             push @query_params, $params->{'type'};
1329         }
1330         if ( $params->{'limit'} ) {
1331             $statement .= ' limit ? ';
1332             push @query_params, $params->{'limit'};
1333         }
1334     }
1335
1336     $debug and warn "_get_unsent_messages SQL: $statement";
1337     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
1338     my $sth = $dbh->prepare( $statement );
1339     my $result = $sth->execute( @query_params );
1340     return $sth->fetchall_arrayref({});
1341 }
1342
1343 sub _send_message_by_email {
1344     my $message = shift or return;
1345     my ($username, $password, $method) = @_;
1346
1347     my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1348     my $to_address = $message->{'to_address'};
1349     unless ($to_address) {
1350         unless ($patron) {
1351             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
1352             _set_message_status( { message_id => $message->{'message_id'},
1353                                    status     => 'failed' } );
1354             return;
1355         }
1356         $to_address = C4::Members::GetNoticeEmailAddress( $message->{'borrowernumber'} );
1357         unless ($to_address) {
1358             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
1359             # warning too verbose for this more common case?
1360             _set_message_status( { message_id => $message->{'message_id'},
1361                                    status     => 'failed' } );
1362             return;
1363         }
1364     }
1365
1366     my $utf8   = decode('MIME-Header', $message->{'subject'} );
1367     $message->{subject}= encode('MIME-Header', $utf8);
1368     my $subject = encode('UTF-8', $message->{'subject'});
1369     my $content = encode('UTF-8', $message->{'content'});
1370     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
1371     my $is_html = $content_type =~ m/html/io;
1372     my $branch_email = undef;
1373     my $branch_replyto = undef;
1374     my $branch_returnpath = undef;
1375     if ($patron) {
1376         my $library = $patron->library;
1377         $branch_email      = $library->branchemail;
1378         $branch_replyto    = $library->branchreplyto;
1379         $branch_returnpath = $library->branchreturnpath;
1380     }
1381     my $email = Koha::Email->new();
1382     my %sendmail_params = $email->create_message_headers(
1383         {
1384             to      => $to_address,
1385             from    => $message->{'from_address'} || $branch_email,
1386             replyto => $branch_replyto,
1387             sender  => $branch_returnpath,
1388             subject => $subject,
1389             message => $is_html ? _wrap_html( $content, $subject ) : $content,
1390             contenttype => $content_type
1391         }
1392     );
1393
1394     $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
1395     if ( my $bcc = C4::Context->preference('NoticeBcc') ) {
1396        $sendmail_params{ Bcc } = $bcc;
1397     }
1398
1399     _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
1400
1401     if ( Mail::Sendmail::sendmail( %sendmail_params ) ) {
1402         _set_message_status( { message_id => $message->{'message_id'},
1403                 status     => 'sent' } );
1404         return 1;
1405     } else {
1406         _set_message_status( { message_id => $message->{'message_id'},
1407                 status     => 'failed' } );
1408         carp $Mail::Sendmail::error;
1409         return;
1410     }
1411 }
1412
1413 sub _wrap_html {
1414     my ($content, $title) = @_;
1415
1416     my $css = C4::Context->preference("NoticeCSS") || '';
1417     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
1418     return <<EOS;
1419 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1420     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1421 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1422 <head>
1423 <title>$title</title>
1424 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1425 $css
1426 </head>
1427 <body>
1428 $content
1429 </body>
1430 </html>
1431 EOS
1432 }
1433
1434 sub _is_duplicate {
1435     my ( $message ) = @_;
1436     my $dbh = C4::Context->dbh;
1437     my $count = $dbh->selectrow_array(q|
1438         SELECT COUNT(*)
1439         FROM message_queue
1440         WHERE message_transport_type = ?
1441         AND borrowernumber = ?
1442         AND letter_code = ?
1443         AND CAST(time_queued AS date) = CAST(NOW() AS date)
1444         AND status="sent"
1445         AND content = ?
1446     |, {}, $message->{message_transport_type}, $message->{borrowernumber}, $message->{letter_code}, $message->{content} );
1447     return $count;
1448 }
1449
1450 sub _send_message_by_sms {
1451     my $message = shift or return;
1452     my $patron = Koha::Patrons->find( $message->{borrowernumber} );
1453
1454     unless ( $patron and $patron->smsalertnumber ) {
1455         _set_message_status( { message_id => $message->{'message_id'},
1456                                status     => 'failed' } );
1457         return;
1458     }
1459
1460     if ( _is_duplicate( $message ) ) {
1461         _set_message_status( { message_id => $message->{'message_id'},
1462                                status     => 'failed' } );
1463         return;
1464     }
1465
1466     my $success = C4::SMS->send_sms( { destination => $patron->smsalertnumber,
1467                                        message     => $message->{'content'},
1468                                      } );
1469     _set_message_status( { message_id => $message->{'message_id'},
1470                            status     => ($success ? 'sent' : 'failed') } );
1471     return $success;
1472 }
1473
1474 sub _update_message_to_address {
1475     my ($id, $to)= @_;
1476     my $dbh = C4::Context->dbh();
1477     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1478 }
1479
1480 sub _set_message_status {
1481     my $params = shift or return;
1482
1483     foreach my $required_parameter ( qw( message_id status ) ) {
1484         return unless exists $params->{ $required_parameter };
1485     }
1486
1487     my $dbh = C4::Context->dbh();
1488     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1489     my $sth = $dbh->prepare( $statement );
1490     my $result = $sth->execute( $params->{'status'},
1491                                 $params->{'message_id'} );
1492     return $result;
1493 }
1494
1495 sub _process_tt {
1496     my ( $params ) = @_;
1497
1498     my $content = $params->{content};
1499     my $tables = $params->{tables};
1500     my $loops = $params->{loops};
1501     my $substitute = $params->{substitute} || {};
1502
1503     my $use_template_cache = C4::Context->config('template_cache_dir') && defined $ENV{GATEWAY_INTERFACE};
1504     my $template           = Template->new(
1505         {
1506             EVAL_PERL    => 1,
1507             ABSOLUTE     => 1,
1508             PLUGIN_BASE  => 'Koha::Template::Plugin',
1509             COMPILE_EXT  => $use_template_cache ? '.ttc' : '',
1510             COMPILE_DIR  => $use_template_cache ? C4::Context->config('template_cache_dir') : '',
1511             FILTERS      => {},
1512             ENCODING     => 'UTF-8',
1513         }
1514     ) or die Template->error();
1515
1516     my $tt_params = { %{ _get_tt_params( $tables ) }, %{ _get_tt_params( $loops, 'is_a_loop' ) }, %$substitute };
1517
1518     $content = add_tt_filters( $content );
1519     $content = qq|[% USE KohaDates %][% USE Remove_MARC_punctuation %]$content|;
1520
1521     my $output;
1522     $template->process( \$content, $tt_params, \$output ) || croak "ERROR PROCESSING TEMPLATE: " . $template->error();
1523
1524     return $output;
1525 }
1526
1527 sub _get_tt_params {
1528     my ($tables, $is_a_loop) = @_;
1529
1530     my $params;
1531     $is_a_loop ||= 0;
1532
1533     my $config = {
1534         article_requests => {
1535             module   => 'Koha::ArticleRequests',
1536             singular => 'article_request',
1537             plural   => 'article_requests',
1538             pk       => 'id',
1539           },
1540         biblio => {
1541             module   => 'Koha::Biblios',
1542             singular => 'biblio',
1543             plural   => 'biblios',
1544             pk       => 'biblionumber',
1545         },
1546         biblioitems => {
1547             module   => 'Koha::Biblioitems',
1548             singular => 'biblioitem',
1549             plural   => 'biblioitems',
1550             pk       => 'biblioitemnumber',
1551         },
1552         borrowers => {
1553             module   => 'Koha::Patrons',
1554             singular => 'borrower',
1555             plural   => 'borrowers',
1556             pk       => 'borrowernumber',
1557         },
1558         branches => {
1559             module   => 'Koha::Libraries',
1560             singular => 'branch',
1561             plural   => 'branches',
1562             pk       => 'branchcode',
1563         },
1564         items => {
1565             module   => 'Koha::Items',
1566             singular => 'item',
1567             plural   => 'items',
1568             pk       => 'itemnumber',
1569         },
1570         opac_news => {
1571             module   => 'Koha::News',
1572             singular => 'news',
1573             plural   => 'news',
1574             pk       => 'idnew',
1575         },
1576         aqorders => {
1577             module   => 'Koha::Acquisition::Orders',
1578             singular => 'order',
1579             plural   => 'orders',
1580             pk       => 'ordernumber',
1581         },
1582         reserves => {
1583             module   => 'Koha::Holds',
1584             singular => 'hold',
1585             plural   => 'holds',
1586             fk       => [ 'borrowernumber', 'biblionumber' ],
1587         },
1588         serial => {
1589             module   => 'Koha::Serials',
1590             singular => 'serial',
1591             plural   => 'serials',
1592             pk       => 'serialid',
1593         },
1594         subscription => {
1595             module   => 'Koha::Subscriptions',
1596             singular => 'subscription',
1597             plural   => 'subscriptions',
1598             pk       => 'subscriptionid',
1599         },
1600         suggestions => {
1601             module   => 'Koha::Suggestions',
1602             singular => 'suggestion',
1603             plural   => 'suggestions',
1604             pk       => 'suggestionid',
1605         },
1606         issues => {
1607             module   => 'Koha::Checkouts',
1608             singular => 'checkout',
1609             plural   => 'checkouts',
1610             fk       => 'itemnumber',
1611         },
1612         old_issues => {
1613             module   => 'Koha::Old::Checkouts',
1614             singular => 'old_checkout',
1615             plural   => 'old_checkouts',
1616             fk       => 'itemnumber',
1617         },
1618         overdues => {
1619             module   => 'Koha::Checkouts',
1620             singular => 'overdue',
1621             plural   => 'overdues',
1622             fk       => 'itemnumber',
1623         },
1624         borrower_modifications => {
1625             module   => 'Koha::Patron::Modifications',
1626             singular => 'patron_modification',
1627             plural   => 'patron_modifications',
1628             fk       => 'verification_token',
1629         },
1630     };
1631
1632     foreach my $table ( keys %$tables ) {
1633         next unless $config->{$table};
1634
1635         my $ref = ref( $tables->{$table} ) || q{};
1636         my $module = $config->{$table}->{module};
1637
1638         if ( can_load( modules => { $module => undef } ) ) {
1639             my $pk = $config->{$table}->{pk};
1640             my $fk = $config->{$table}->{fk};
1641
1642             if ( $is_a_loop ) {
1643                 my $values = $tables->{$table} || [];
1644                 unless ( ref( $values ) eq 'ARRAY' ) {
1645                     croak "ERROR processing table $table. Wrong API call.";
1646                 }
1647                 my $key = $pk ? $pk : $fk;
1648                 # $key does not come from user input
1649                 my $objects = $module->search(
1650                     { $key => $values },
1651                     {
1652                             # We want to retrieve the data in the same order
1653                             # FIXME MySQLism
1654                             # field is a MySQLism, but they are no other way to do it
1655                             # To be generic we could do it in perl, but we will need to fetch
1656                             # all the data then order them
1657                         @$values ? ( order_by => \[ "field($key, " . join( ', ', @$values ) . ")" ] ) : ()
1658                     }
1659                 );
1660                 $params->{ $config->{$table}->{plural} } = $objects;
1661             }
1662             elsif ( $ref eq q{} || $ref eq 'HASH' ) {
1663                 my $id = ref $ref eq 'HASH' ? $tables->{$table}->{$pk} : $tables->{$table};
1664                 my $object;
1665                 if ( $fk ) { # Using a foreign key for lookup
1666                     if ( ref( $fk ) eq 'ARRAY' ) { # Foreign key is multi-column
1667                         my $search;
1668                         foreach my $key ( @$fk ) {
1669                             $search->{$key} = $id->{$key};
1670                         }
1671                         $object = $module->search( $search )->last();
1672                     } else { # Foreign key is single column
1673                         $object = $module->search( { $fk => $id } )->last();
1674                     }
1675                 } else { # using the table's primary key for lookup
1676                     $object = $module->find($id);
1677                 }
1678                 $params->{ $config->{$table}->{singular} } = $object;
1679             }
1680             else {    # $ref eq 'ARRAY'
1681                 my $object;
1682                 if ( @{ $tables->{$table} } == 1 ) {    # Param is a single key
1683                     $object = $module->search( { $pk => $tables->{$table} } )->last();
1684                 }
1685                 else {                                  # Params are mutliple foreign keys
1686                     croak "Multiple foreign keys (table $table) should be passed using an hashref";
1687                 }
1688                 $params->{ $config->{$table}->{singular} } = $object;
1689             }
1690         }
1691         else {
1692             croak "ERROR LOADING MODULE $module: $Module::Load::Conditional::ERROR";
1693         }
1694     }
1695
1696     $params->{today} = output_pref({ dt => dt_from_string, dateformat => 'iso' });
1697
1698     return $params;
1699 }
1700
1701 =head3 add_tt_filters
1702
1703 $content = add_tt_filters( $content );
1704
1705 Add TT filters to some specific fields if needed.
1706
1707 For now we only add the Remove_MARC_punctuation TT filter to biblio and biblioitem fields
1708
1709 =cut
1710
1711 sub add_tt_filters {
1712     my ( $content ) = @_;
1713     $content =~ s|\[%\s*biblio\.(.*?)\s*%\]|[% biblio.$1 \| \$Remove_MARC_punctuation %]|gxms;
1714     $content =~ s|\[%\s*biblioitem\.(.*?)\s*%\]|[% biblioitem.$1 \| \$Remove_MARC_punctuation %]|gxms;
1715     return $content;
1716 }
1717
1718 =head2 get_item_content
1719
1720     my $item = Koha::Items->find(...)->unblessed;
1721     my @item_content_fields = qw( date_due title barcode author itemnumber );
1722     my $item_content = C4::Letters::get_item_content({
1723                              item => $item,
1724                              item_content_fields => \@item_content_fields
1725                        });
1726
1727 This function generates a tab-separated list of values for the passed item. Dates
1728 are formatted following the current setup.
1729
1730 =cut
1731
1732 sub get_item_content {
1733     my ( $params ) = @_;
1734     my $item = $params->{item};
1735     my $dateonly = $params->{dateonly} || 0;
1736     my $item_content_fields = $params->{item_content_fields} || [];
1737
1738     return unless $item;
1739
1740     my @item_info = map {
1741         $_ =~ /^date|date$/
1742           ? eval {
1743             output_pref(
1744                 { dt => dt_from_string( $item->{$_} ), dateonly => $dateonly } );
1745           }
1746           : $item->{$_}
1747           || ''
1748     } @$item_content_fields;
1749     return join( "\t", @item_info ) . "\n";
1750 }
1751
1752 1;
1753 __END__