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