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::Log;
  32 use C4::SMS;
  33 use C4::Debug;
  34 use Koha::DateUtils;
  35 use Koha::SMS::Providers;
  36
  37 use Koha::Email;
  38 use Koha::Notice::Messages;
  39 use Koha::Notice::Templates;
  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     return Koha::Notice::Templates->search(
 126         {
 127             module     => $module,
 128             code       => $code,
 129             branchcode => $branchcode,
 130             (
 131                 C4::Context->preference('TranslateNotices')
 132                 ? ()
 133                 : ( lang => 'default' )
 134             )
 135         }
 136     )->unblessed;
 137 }
 138
 139 =head2 GetLettersAvailableForALibrary
 140
 141     my $letters = GetLettersAvailableForALibrary(
 142         {
 143             branchcode => 'CPL', # '' for default
 144             module => 'circulation',
 145         }
 146     );
 147
 148     Return an arrayref of letters, sorted by name.
 149     If a specific letter exist for the given branchcode, it will be retrieve.
 150     Otherwise the default letter will be.
 151
 152 =cut
 153
 154 sub GetLettersAvailableForALibrary {
 155     my ($filters)  = @_;
 156     my $branchcode = $filters->{branchcode};
 157     my $module     = $filters->{module};
 158
 159     croak "module should be provided" unless $module;
 160
 161     my $dbh             = C4::Context->dbh;
 162     my $default_letters = $dbh->selectall_arrayref(
 163         q|
 164             SELECT module, code, branchcode, name
 165             FROM letter
 166             WHERE 1
 167         |
 168           . q| AND branchcode = ''|
 169           . ( $module ? q| AND module = ?| : q|| )
 170           . q| ORDER BY name|, { Slice => {} }
 171         , ( $module ? $module : () )
 172     );
 173
 174     my $specific_letters;
 175     if ($branchcode) {
 176         $specific_letters = $dbh->selectall_arrayref(
 177             q|
 178                 SELECT module, code, branchcode, name
 179                 FROM letter
 180                 WHERE 1
 181             |
 182               . q| AND branchcode = ?|
 183               . ( $module ? q| AND module = ?| : q|| )
 184               . q| ORDER BY name|, { Slice => {} }
 185             , $branchcode
 186             , ( $module ? $module : () )
 187         );
 188     }
 189
 190     my %letters;
 191     for my $l (@$default_letters) {
 192         $letters{ $l->{code} } = $l;
 193     }
 194     for my $l (@$specific_letters) {
 195         # Overwrite the default letter with the specific one.
 196         $letters{ $l->{code} } = $l;
 197     }
 198
 199     return [ map { $letters{$_} }
 200           sort { $letters{$a}->{name} cmp $letters{$b}->{name} }
 201           keys %letters ];
 202
 203 }
 204
 205 sub getletter {
 206     my ( $module, $code, $branchcode, $message_transport_type, $lang) = @_;
 207     $message_transport_type //= '%';
 208     $lang = 'default' unless( $lang && C4::Context->preference('TranslateNotices') );
 209
 210
 211     my $only_my_library = C4::Context->only_my_library;
 212     if ( $only_my_library and $branchcode ) {
 213         $branchcode = C4::Context::mybranch();
 214     }
 215     $branchcode //= '';
 216
 217     my $dbh = C4::Context->dbh;
 218     my $sth = $dbh->prepare(q{
 219         SELECT *
 220         FROM letter
 221         WHERE module=? AND code=? AND (branchcode = ? OR branchcode = '')
 222         AND message_transport_type LIKE ?
 223         AND lang =?
 224         ORDER BY branchcode DESC LIMIT 1
 225     });
 226     $sth->execute( $module, $code, $branchcode, $message_transport_type, $lang );
 227     my $line = $sth->fetchrow_hashref
 228       or return;
 229     $line->{'content-type'} = 'text/html; charset="UTF-8"' if $line->{is_html};
 230     return { %$line };
 231 }
 232
 233
 234 =head2 DelLetter
 235
 236     DelLetter(
 237         {
 238             branchcode => 'CPL',
 239             module => 'circulation',
 240             code => 'my code',
 241             [ mtt => 'email', ]
 242         }
 243     );
 244
 245     Delete the letter. The mtt parameter is facultative.
 246     If not given, all templates mathing the other parameters will be removed.
 247
 248 =cut
 249
 250 sub DelLetter {
 251     my ($params)   = @_;
 252     my $branchcode = $params->{branchcode};
 253     my $module     = $params->{module};
 254     my $code       = $params->{code};
 255     my $mtt        = $params->{mtt};
 256     my $lang       = $params->{lang};
 257     my $dbh        = C4::Context->dbh;
 258     $dbh->do(q|
 259         DELETE FROM letter
 260         WHERE branchcode = ?
 261           AND module = ?
 262           AND code = ?
 263     |
 264     . ( $mtt ? q| AND message_transport_type = ?| : q|| )
 265     . ( $lang? q| AND lang = ?| : q|| )
 266     , undef, $branchcode, $module, $code, ( $mtt ? $mtt : () ), ( $lang ? $lang : () ) );
 267 }
 268
 269 =head2 SendAlerts
 270
 271     my $err = &SendAlerts($type, $externalid, $letter_code);
 272
 273     Parameters:
 274       - $type : the type of alert
 275       - $externalid : the id of the "object" to query
 276       - $letter_code : the notice template to use
 277
 278     C<&SendAlerts> sends an email notice directly to a patron or a vendor.
 279
 280     Currently it supports ($type):
 281       - claim serial issues (claimissues)
 282       - claim acquisition orders (claimacquisition)
 283       - send acquisition orders to the vendor (orderacquisition)
 284       - notify patrons about newly received serial issues (issue)
 285       - notify patrons when their account is created (members)
 286
 287     Returns undef or { error => 'message } on failure.
 288     Returns true on success.
 289
 290 =cut
 291
 292 sub SendAlerts {
 293     my ( $type, $externalid, $letter_code ) = @_;
 294     my $dbh = C4::Context->dbh;
 295     if ( $type eq 'issue' ) {
 296
 297         # prepare the letter...
 298         # search the subscriptionid
 299         my $sth =
 300           $dbh->prepare(
 301             "SELECT subscriptionid FROM serial WHERE serialid=?");
 302         $sth->execute($externalid);
 303         my ($subscriptionid) = $sth->fetchrow
 304           or warn( "No subscription for '$externalid'" ),
 305              return;
 306
 307         # search the biblionumber
 308         $sth =
 309           $dbh->prepare(
 310             "SELECT biblionumber FROM subscription WHERE subscriptionid=?");
 311         $sth->execute($subscriptionid);
 312         my ($biblionumber) = $sth->fetchrow
 313           or warn( "No biblionumber for '$subscriptionid'" ),
 314              return;
 315
 316         my %letter;
 317         # find the list of subscribers to notify
 318         my $subscription = Koha::Subscriptions->find( $subscriptionid );
 319         my $subscribers = $subscription->subscribers;
 320         while ( my $patron = $subscribers->next ) {
 321             my $email = $patron->email or next;
 322
 323 #                    warn "sending issues...";
 324             my $userenv = C4::Context->userenv;
 325             my $library = $patron->library;
 326             my $letter = GetPreparedLetter (
 327                 module => 'serial',
 328                 letter_code => $letter_code,
 329                 branchcode => $userenv->{branch},
 330                 tables => {
 331                     'branches'    => $library->branchcode,
 332                     'biblio'      => $biblionumber,
 333                     'biblioitems' => $biblionumber,
 334                     'borrowers'   => $patron->unblessed,
 335                     'subscription' => $subscriptionid,
 336                     'serial' => $externalid,
 337                 },
 338                 want_librarian => 1,
 339             ) or return;
 340
 341             # ... then send mail
 342             my $message = Koha::Email->new();
 343             my %mail = $message->create_message_headers(
 344                 {
 345                     to      => $email,
 346                     from    => $library->branchemail,
 347                     replyto => $library->branchreplyto,
 348                     sender  => $library->branchreturnpath,
 349                     subject => Encode::encode( "UTF-8", "" . $letter->{title} ),
 350                     message => $letter->{'is_html'}
 351                                 ? _wrap_html( Encode::encode( "UTF-8", $letter->{'content'} ),
 352                                               Encode::encode( "UTF-8", "" . $letter->{'title'} ))
 353                                 : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
 354                     contenttype => $letter->{'is_html'}
 355                                     ? 'text/html; charset="utf-8"'
 356                                     : 'text/plain; charset="utf-8"',
 357                 }
 358             );
 359             unless( Mail::Sendmail::sendmail(%mail) ) {
 360                 carp $Mail::Sendmail::error;
 361                 return { error => $Mail::Sendmail::error };
 362             }
 363         }
 364     }
 365     elsif ( $type eq 'claimacquisition' or $type eq 'claimissues' or $type eq 'orderacquisition' ) {
 366
 367         # prepare the letter...
 368         my $strsth;
 369         my $sthorders;
 370         my $dataorders;
 371         my $action;
 372         if ( $type eq 'claimacquisition') {
 373             $strsth = qq{
 374             SELECT aqorders.*,aqbasket.*,biblio.*,biblioitems.*
 375             FROM aqorders
 376             LEFT JOIN aqbasket ON aqbasket.basketno=aqorders.basketno
 377             LEFT JOIN biblio ON aqorders.biblionumber=biblio.biblionumber
 378             LEFT JOIN biblioitems ON aqorders.biblionumber=biblioitems.biblionumber
 379             WHERE aqorders.ordernumber IN (
 380             };
 381
 382             if (!@$externalid){
 383                 carp "No order selected";
 384                 return { error => "no_order_selected" };
 385             }
 386             $strsth .= join( ",", ('?') x @$externalid ) . ")";
 387             $action = "ACQUISITION CLAIM";
 388             $sthorders = $dbh->prepare($strsth);
 389             $sthorders->execute( @$externalid );
 390             $dataorders = $sthorders->fetchall_arrayref( {} );
 391         }
 392
 393         if ($type eq 'claimissues') {
 394             $strsth = qq{
 395             SELECT serial.*,subscription.*, biblio.*, biblioitems.*, aqbooksellers.*,
 396             aqbooksellers.id AS booksellerid
 397             FROM serial
 398             LEFT JOIN subscription ON serial.subscriptionid=subscription.subscriptionid
 399             LEFT JOIN biblio ON serial.biblionumber=biblio.biblionumber
 400             LEFT JOIN biblioitems ON serial.biblionumber = biblioitems.biblionumber
 401             LEFT JOIN aqbooksellers ON subscription.aqbooksellerid=aqbooksellers.id
 402             WHERE serial.serialid IN (
 403             };
 404
 405             if (!@$externalid){
 406                 carp "No issues selected";
 407                 return { error => "no_issues_selected" };
 408             }
 409
 410             $strsth .= join( ",", ('?') x @$externalid ) . ")";
 411             $action = "SERIAL CLAIM";
 412             $sthorders = $dbh->prepare($strsth);
 413             $sthorders->execute( @$externalid );
 414             $dataorders = $sthorders->fetchall_arrayref( {} );
 415         }
 416
 417         if ( $type eq 'orderacquisition') {
 418             $strsth = qq{
 419             SELECT aqorders.*,aqbasket.*,biblio.*,biblioitems.*
 420             FROM aqorders
 421             LEFT JOIN aqbasket ON aqbasket.basketno=aqorders.basketno
 422             LEFT JOIN biblio ON aqorders.biblionumber=biblio.biblionumber
 423             LEFT JOIN biblioitems ON aqorders.biblionumber=biblioitems.biblionumber
 424             WHERE aqbasket.basketno = ?
 425             AND orderstatus IN ('new','ordered')
 426             };
 427
 428             if (!$externalid){
 429                 carp "No basketnumber given";
 430                 return { error => "no_basketno" };
 431             }
 432             $action = "ACQUISITION ORDER";
 433             $sthorders = $dbh->prepare($strsth);
 434             $sthorders->execute($externalid);
 435             $dataorders = $sthorders->fetchall_arrayref( {} );
 436         }
 437
 438         my $sthbookseller =
 439           $dbh->prepare("select * from aqbooksellers where id=?");
 440         $sthbookseller->execute( $dataorders->[0]->{booksellerid} );
 441         my $databookseller = $sthbookseller->fetchrow_hashref;
 442
 443         my $addressee =  $type eq 'claimacquisition' || $type eq 'orderacquisition' ? 'acqprimary' : 'serialsprimary';
 444
 445         my $sthcontact =
 446           $dbh->prepare("SELECT * FROM aqcontacts WHERE booksellerid=? AND $type=1 ORDER BY $addressee DESC");
 447         $sthcontact->execute( $dataorders->[0]->{booksellerid} );
 448         my $datacontact = $sthcontact->fetchrow_hashref;
 449
 450         my @email;
 451         my @cc;
 452         push @email, $datacontact->{email}           if ( $datacontact && $datacontact->{email} );
 453         unless (@email) {
 454             warn "Bookseller $dataorders->[0]->{booksellerid} without emails";
 455             return { error => "no_email" };
 456         }
 457         my $addlcontact;
 458         while ($addlcontact = $sthcontact->fetchrow_hashref) {
 459             push @cc, $addlcontact->{email} if ( $addlcontact && $addlcontact->{email} );
 460         }
 461
 462         my $userenv = C4::Context->userenv;
 463         my $letter = GetPreparedLetter (
 464             module => $type,
 465             letter_code => $letter_code,
 466             branchcode => $userenv->{branch},
 467             tables => {
 468                 'branches'    => $userenv->{branch},
 469                 'aqbooksellers' => $databookseller,
 470                 'aqcontacts'    => $datacontact,
 471             },
 472             repeat => $dataorders,
 473             want_librarian => 1,
 474         ) or return { error => "no_letter" };
 475
 476         # Remove the order tag
 477         $letter->{content} =~ s/<order>(.*?)<\/order>/$1/gxms;
 478
 479         # ... then send mail
 480         my $library = Koha::Libraries->find( $userenv->{branch} );
 481         my $email = Koha::Email->new();
 482         my %mail = $email->create_message_headers(
 483             {
 484                 to => join( ',', @email ),
 485                 cc => join( ',', @cc ),
 486                 (
 487                     (
 488                         C4::Context->preference("ClaimsBccCopy")
 489                           && ( $type eq 'claimacquisition'
 490                             || $type eq 'claimissues' )
 491                     ) ? ( bcc => $userenv->{emailaddress} )
 492                     : ()
 493                 ),
 494                 from => $library->branchemail
 495                   || C4::Context->preference('KohaAdminEmailAddress'),
 496                 subject => Encode::encode( "UTF-8", "" . $letter->{title} ),
 497                 message => $letter->{'is_html'} ? _wrap_html(
 498                     Encode::encode( "UTF-8", $letter->{'content'} ),
 499                     Encode::encode( "UTF-8", "" . $letter->{'title'} )
 500                   )
 501                 : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
 502                 contenttype => $letter->{'is_html'}
 503                 ? 'text/html; charset="utf-8"'
 504                 : 'text/plain; charset="utf-8"',
 505             }
 506         );
 507
 508         unless ( Mail::Sendmail::sendmail(%mail) ) {
 509             carp $Mail::Sendmail::error;
 510             return { error => $Mail::Sendmail::error };
 511         }
 512
 513         logaction(
 514             "ACQUISITION",
 515             $action,
 516             undef,
 517             "To="
 518                 . join( ',', @email )
 519                 . " Title="
 520                 . $letter->{title}
 521                 . " Content="
 522                 . $letter->{content}
 523         ) if C4::Context->preference("LetterLog");
 524     }
 525    # send an "account details" notice to a newly created user
 526     elsif ( $type eq 'members' ) {
 527         my $library = Koha::Libraries->find( $externalid->{branchcode} )->unblessed;
 528         my $letter = GetPreparedLetter (
 529             module => 'members',
 530             letter_code => $letter_code,
 531             branchcode => $externalid->{'branchcode'},
 532             lang       => $externalid->{lang} || 'default',
 533             tables => {
 534                 'branches'    => $library,
 535                 'borrowers' => $externalid->{'borrowernumber'},
 536             },
 537             substitute => { 'borrowers.password' => $externalid->{'password'} },
 538             want_librarian => 1,
 539         ) or return;
 540         return { error => "no_email" } unless $externalid->{'emailaddr'};
 541         my $email = Koha::Email->new();
 542         my %mail  = $email->create_message_headers(
 543             {
 544                 to      => $externalid->{'emailaddr'},
 545                 from    => $library->{branchemail},
 546                 replyto => $library->{branchreplyto},
 547                 sender  => $library->{branchreturnpath},
 548                 subject => Encode::encode( "UTF-8", "" . $letter->{'title'} ),
 549                 message => $letter->{'is_html'}
 550                             ? _wrap_html( Encode::encode( "UTF-8", $letter->{'content'} ),
 551                                           Encode::encode( "UTF-8", "" . $letter->{'title'}  ) )
 552                             : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
 553                 contenttype => $letter->{'is_html'}
 554                                 ? 'text/html; charset="utf-8"'
 555                                 : 'text/plain; charset="utf-8"',
 556             }
 557         );
 558         unless( Mail::Sendmail::sendmail(%mail) ) {
 559             carp $Mail::Sendmail::error;
 560             return { error => $Mail::Sendmail::error };
 561         }
 562     }
 563
 564     # If we come here, return an OK status
 565     return 1;
 566 }
 567
 568 =head2 GetPreparedLetter( %params )
 569
 570     %params hash:
 571       module => letter module, mandatory
 572       letter_code => letter code, mandatory
 573       branchcode => for letter selection, if missing default system letter taken
 574       tables => a hashref with table names as keys. Values are either:
 575         - a scalar - primary key value
 576         - an arrayref - primary key values
 577         - a hashref - full record
 578       substitute => custom substitution key/value pairs
 579       repeat => records to be substituted on consecutive lines:
 580         - an arrayref - tries to guess what needs substituting by
 581           taking remaining << >> tokensr; not recommended
 582         - a hashref token => @tables - replaces <token> << >> << >> </token>
 583           subtemplate for each @tables row; table is a hashref as above
 584       want_librarian => boolean,  if set to true triggers librarian details
 585         substitution from the userenv
 586     Return value:
 587       letter fields hashref (title & content useful)
 588
 589 =cut
 590
 591 sub GetPreparedLetter {
 592     my %params = @_;
 593
 594     my $letter = $params{letter};
 595
 596     unless ( $letter ) {
 597         my $module      = $params{module} or croak "No module";
 598         my $letter_code = $params{letter_code} or croak "No letter_code";
 599         my $branchcode  = $params{branchcode} || '';
 600         my $mtt         = $params{message_transport_type} || 'email';
 601         my $lang        = $params{lang} || 'default';
 602
 603         $letter = getletter( $module, $letter_code, $branchcode, $mtt, $lang );
 604
 605         unless ( $letter ) {
 606             $letter = getletter( $module, $letter_code, $branchcode, $mtt, 'default' )
 607                 or warn( "No $module $letter_code letter transported by " . $mtt ),
 608                     return;
 609         }
 610     }
 611
 612     my $tables = $params{tables} || {};
 613     my $substitute = $params{substitute} || {};
 614     my $loops  = $params{loops} || {}; # loops is not supported for historical notices syntax
 615     my $repeat = $params{repeat};
 616     %$tables || %$substitute || $repeat || %$loops
 617       or carp( "ERROR: nothing to substitute - both 'tables', 'loops' and 'substitute' are empty" ),
 618          return;
 619     my $want_librarian = $params{want_librarian};
 620
 621     if (%$substitute) {
 622         while ( my ($token, $val) = each %$substitute ) {
 623             if ( $token eq 'items.content' ) {
 624                 $val =~ s|\n|<br/>|g if $letter->{is_html};
 625             }
 626
 627             $letter->{title} =~ s/<<$token>>/$val/g;
 628             $letter->{content} =~ s/<<$token>>/$val/g;
 629        }
 630     }
 631
 632     my $OPACBaseURL = C4::Context->preference('OPACBaseURL');
 633     $letter->{content} =~ s/<<OPACBaseURL>>/$OPACBaseURL/go;
 634
 635     if ($want_librarian) {
 636         # parsing librarian name
 637         my $userenv = C4::Context->userenv;
 638         $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/go;
 639         $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/go;
 640         $letter->{content} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/go;
 641     }
 642
 643     my ($repeat_no_enclosing_tags, $repeat_enclosing_tags);
 644
 645     if ($repeat) {
 646         if (ref ($repeat) eq 'ARRAY' ) {
 647             $repeat_no_enclosing_tags = $repeat;
 648         } else {
 649             $repeat_enclosing_tags = $repeat;
 650         }
 651     }
 652
 653     if ($repeat_enclosing_tags) {
 654         while ( my ($tag, $tag_tables) = each %$repeat_enclosing_tags ) {
 655             if ( $letter->{content} =~ m!<$tag>(.*)</$tag>!s ) {
 656                 my $subcontent = $1;
 657                 my @lines = map {
 658                     my %subletter = ( title => '', content => $subcontent );
 659                     _substitute_tables( \%subletter, $_ );
 660                     $subletter{content};
 661                 } @$tag_tables;
 662                 $letter->{content} =~ s!<$tag>.*</$tag>!join( "\n", @lines )!se;
 663             }
 664         }
 665     }
 666
 667     if (%$tables) {
 668         _substitute_tables( $letter, $tables );
 669     }
 670
 671     if ($repeat_no_enclosing_tags) {
 672         if ( $letter->{content} =~ m/[^\n]*<<.*>>[^\n]*/so ) {
 673             my $line = $&;
 674             my $i = 1;
 675             my @lines = map {
 676                 my $c = $line;
 677                 $c =~ s/<<count>>/$i/go;
 678                 foreach my $field ( keys %{$_} ) {
 679                     $c =~ s/(<<[^\.]+.$field>>)/$_->{$field}/;
 680                 }
 681                 $i++;
 682                 $c;
 683             } @$repeat_no_enclosing_tags;
 684
 685             my $replaceby = join( "\n", @lines );
 686             $letter->{content} =~ s/\Q$line\E/$replaceby/s;
 687         }
 688     }
 689
 690     $letter->{content} = _process_tt(
 691         {
 692             content => $letter->{content},
 693             tables  => $tables,
 694             loops  => $loops,
 695             substitute => $substitute,
 696         }
 697     );
 698
 699     $letter->{content} =~ s/<<\S*>>//go; #remove any stragglers
 700
 701     return $letter;
 702 }
 703
 704 sub _substitute_tables {
 705     my ( $letter, $tables ) = @_;
 706     while ( my ($table, $param) = each %$tables ) {
 707         next unless $param;
 708
 709         my $ref = ref $param;
 710
 711         my $values;
 712         if ($ref && $ref eq 'HASH') {
 713             $values = $param;
 714         }
 715         else {
 716             my $sth = _parseletter_sth($table);
 717             unless ($sth) {
 718                 warn "_parseletter_sth('$table') failed to return a valid sth.  No substitution will be done for that table.";
 719                 return;
 720             }
 721             $sth->execute( $ref ? @$param : $param );
 722
 723             $values = $sth->fetchrow_hashref;
 724             $sth->finish();
 725         }
 726
 727         _parseletter ( $letter, $table, $values );
 728     }
 729 }
 730
 731 sub _parseletter_sth {
 732     my $table = shift;
 733     my $sth;
 734     unless ($table) {
 735         carp "ERROR: _parseletter_sth() called without argument (table)";
 736         return;
 737     }
 738     # NOTE: we used to check whether we had a statement handle cached in
 739     #       a %handles module-level variable. This was a dumb move and
 740     #       broke things for the rest of us. prepare_cached is a better
 741     #       way to cache statement handles anyway.
 742     my $query =
 743     ($table eq 'biblio'       )    ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 744     ($table eq 'biblioitems'  )    ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 745     ($table eq 'items'        )    ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 746     ($table eq 'issues'       )    ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 747     ($table eq 'old_issues'   )    ? "SELECT * FROM $table WHERE     itemnumber = ? ORDER BY timestamp DESC LIMIT 1"  :
 748     ($table eq 'reserves'     )    ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?"             :
 749     ($table eq 'borrowers'    )    ? "SELECT * FROM $table WHERE borrowernumber = ?"                                  :
 750     ($table eq 'branches'     )    ? "SELECT * FROM $table WHERE     branchcode = ?"                                  :
 751     ($table eq 'suggestions'  )    ? "SELECT * FROM $table WHERE   suggestionid = ?"                                  :
 752     ($table eq 'aqbooksellers')    ? "SELECT * FROM $table WHERE             id = ?"                                  :
 753     ($table eq 'aqorders'     )    ? "SELECT * FROM $table WHERE    ordernumber = ?"                                  :
 754     ($table eq 'opac_news'    )    ? "SELECT * FROM $table WHERE          idnew = ?"                                  :
 755     ($table eq 'article_requests') ? "SELECT * FROM $table WHERE             id = ?"                                  :
 756     ($table eq 'borrower_modifications') ? "SELECT * FROM $table WHERE verification_token = ?" :
 757     ($table eq 'subscription') ? "SELECT * FROM $table WHERE subscriptionid = ?" :
 758     ($table eq 'serial') ? "SELECT * FROM $table WHERE serialid = ?" :
 759     undef ;
 760     unless ($query) {
 761         warn "ERROR: No _parseletter_sth query for table '$table'";
 762         return;     # nothing to get
 763     }
 764     unless ($sth = C4::Context->dbh->prepare_cached($query)) {
 765         warn "ERROR: Failed to prepare query: '$query'";
 766         return;
 767     }
 768     return $sth;    # now cache is populated for that $table
 769 }
 770
 771 =head2 _parseletter($letter, $table, $values)
 772
 773     parameters :
 774     - $letter : a hash to letter fields (title & content useful)
 775     - $table : the Koha table to parse.
 776     - $values_in : table record hashref
 777     parse all fields from a table, and replace values in title & content with the appropriate value
 778     (not exported sub, used only internally)
 779
 780 =cut
 781
 782 sub _parseletter {
 783     my ( $letter, $table, $values_in ) = @_;
 784
 785     # Work on a local copy of $values_in (passed by reference) to avoid side effects
 786     # in callers ( by changing / formatting values )
 787     my $values = $values_in ? { %$values_in } : {};
 788
 789     if ( $table eq 'borrowers' && $values->{'dateexpiry'} ){
 790         $values->{'dateexpiry'} = output_pref({ dt => dt_from_string( $values->{'dateexpiry'} ), dateonly => 1 });
 791     }
 792
 793     if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
 794         $values->{'waitingdate'} = output_pref({ dt => dt_from_string( $values->{'waitingdate'} ), dateonly => 1 });
 795     }
 796
 797     if ($letter->{content} && $letter->{content} =~ /<<today>>/) {
 798         my $todaysdate = output_pref( DateTime->now() );
 799         $letter->{content} =~ s/<<today>>/$todaysdate/go;
 800     }
 801
 802     while ( my ($field, $val) = each %$values ) {
 803         $val =~ s/\p{P}$// if $val && $table=~/biblio/;
 804             #BZ 9886: Assuming that we want to eliminate ISBD punctuation here
 805             #Therefore adding the test on biblio. This includes biblioitems,
 806             #but excludes items. Removed unneeded global and lookahead.
 807
 808         if ( $table=~/^borrowers$/ && $field=~/^streettype$/ ) {
 809             my $av = Koha::AuthorisedValues->search({ category => 'ROADTYPE', authorised_value => $val });
 810             $val = $av->count ? $av->next->lib : '';
 811         }
 812
 813         # Dates replacement
 814         my $replacedby   = defined ($val) ? $val : '';
 815         if (    $replacedby
 816             and not $replacedby =~ m|0000-00-00|
 817             and not $replacedby =~ m|9999-12-31|
 818             and $replacedby =~ m|^\d{4}-\d{2}-\d{2}( \d{2}:\d{2}:\d{2})?$| )
 819         {
 820             # If the value is XXXX-YY-ZZ[ AA:BB:CC] we assume it is a date
 821             my $dateonly = defined $1 ? 0 : 1; #$1 refers to the capture group wrapped in parentheses. In this case, that's the hours, minutes, seconds.
 822             my $re_dateonly_filter = qr{ $field( \s* \| \s* dateonly\s*)?>> }xms;
 823
 824             for my $letter_field ( qw( title content ) ) {
 825                 my $filter_string_used = q{};
 826                 if ( $letter->{ $letter_field } =~ $re_dateonly_filter ) {
 827                     # We overwrite $dateonly if the filter exists and we have a time in the datetime
 828                     $filter_string_used = $1 || q{};
 829                     $dateonly = $1 unless $dateonly;
 830                 }
 831                 my $replacedby_date = eval {
 832                     output_pref({ dt => dt_from_string( $replacedby ), dateonly => $dateonly });
 833                 };
 834
 835                 if ( $letter->{ $letter_field } ) {
 836                     $letter->{ $letter_field } =~ s/\Q<<$table.$field$filter_string_used>>\E/$replacedby_date/g;
 837                     $letter->{ $letter_field } =~ s/\Q<<$field$filter_string_used>>\E/$replacedby_date/g;
 838                 }
 839             }
 840         }
 841         # Other fields replacement
 842         else {
 843             for my $letter_field ( qw( title content ) ) {
 844                 if ( $letter->{ $letter_field } ) {
 845                     $letter->{ $letter_field }   =~ s/<<$table.$field>>/$replacedby/g;
 846                     $letter->{ $letter_field }   =~ s/<<$field>>/$replacedby/g;
 847                 }
 848             }
 849         }
 850     }
 851
 852     if ($table eq 'borrowers' && $letter->{content}) {
 853         my $patron = Koha::Patrons->find( $values->{borrowernumber} );
 854         if ( $patron ) {
 855             my $attributes = $patron->extended_attributes;
 856             my %attr;
 857             while ( my $attribute = $attributes->next ) {
 858                 my $code = $attribute->code;
 859                 my $val  = $attribute->description; # FIXME - we always display intranet description here!
 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__