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