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