C4/Letters.pm

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