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