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 strict;
  21 use warnings;
  22
  23 use MIME::Lite;
  24 use Mail::Sendmail;
  25
  26 use C4::Koha qw(GetAuthorisedValueByCode);
  27 use C4::Members;
  28 use C4::Members::Attributes qw(GetBorrowerAttributes);
  29 use C4::Branch;
  30 use C4::Log;
  31 use C4::SMS;
  32 use C4::Debug;
  33 use Koha::DateUtils;
  34 use Date::Calc qw( Add_Delta_Days );
  35 use Encode;
  36 use Carp;
  37 use Koha::Email;
  38 use Koha::DateUtils qw( format_sqldatetime );
  39
  40 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  41
  42 BEGIN {
  43     require Exporter;
  44     # set the version for version checking
  45     $VERSION = 3.07.00.049;
  46     @ISA = qw(Exporter);
  47     @EXPORT = qw(
  48         &GetLetters &GetLettersAvailableForALibrary &GetLetterTemplates &DelLetter &GetPreparedLetter &GetWrappedLetter &addalert &getalert &delalert &findrelatedto &SendAlerts &GetPrintMessages &GetMessageTransportTypes
  49     );
  50 }
  51
  52 =head1 NAME
  53
  54 C4::Letters - Give functions for Letters management
  55
  56 =head1 SYNOPSIS
  57
  58   use C4::Letters;
  59
  60 =head1 DESCRIPTION
  61
  62   "Letters" is the tool used in Koha to manage informations sent to the patrons and/or the library. This include some cron jobs like
  63   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)
  64
  65   Letters are managed through "alerts" sent by Koha on some events. All "alert" related functions are in this module too.
  66
  67 =head2 GetLetters([$module])
  68
  69   $letters = &GetLetters($module);
  70   returns informations about letters.
  71   if needed, $module filters for letters given module
  72
  73 =cut
  74
  75 sub GetLetters {
  76     my ($filters) = @_;
  77     my $module    = $filters->{module};
  78     my $code      = $filters->{code};
  79     my $branchcode = $filters->{branchcode};
  80     my $dbh       = C4::Context->dbh;
  81     my $letters   = $dbh->selectall_arrayref(
  82         q|
  83             SELECT module, code, branchcode, name
  84             FROM letter
  85             WHERE 1
  86         |
  87           . ( $module ? q| AND module = ?| : q|| )
  88           . ( $code   ? q| AND code = ?|   : q|| )
  89           . ( defined $branchcode   ? q| AND branchcode = ?|   : q|| )
  90           . q| GROUP BY code ORDER BY name|, { Slice => {} }
  91         , ( $module ? $module : () )
  92         , ( $code ? $code : () )
  93         , ( defined $branchcode ? $branchcode : () )
  94     );
  95
  96     return $letters;
  97 }
  98
  99 =head2 GetLetterTemplates
 100
 101     my $letter_templates = GetLetterTemplates(
 102         {
 103             module => 'circulation',
 104             code => 'my code',
 105             branchcode => 'CPL', # '' for default,
 106         }
 107     );
 108
 109     Return a hashref of letter templates.
 110     The key will be the message transport type.
 111
 112 =cut
 113
 114 sub GetLetterTemplates {
 115     my ( $params ) = @_;
 116
 117     my $module    = $params->{module};
 118     my $code      = $params->{code};
 119     my $branchcode = $params->{branchcode} // '';
 120     my $dbh       = C4::Context->dbh;
 121     my $letters   = $dbh->selectall_hashref(
 122         q|
 123             SELECT module, code, branchcode, name, is_html, title, content, message_transport_type
 124             FROM letter
 125             WHERE module = ?
 126             AND code = ?
 127             and branchcode = ?
 128         |
 129         , 'message_transport_type'
 130         , undef
 131         , $module, $code, $branchcode
 132     );
 133
 134     return $letters;
 135 }
 136
 137 =head2 GetLettersAvailableForALibrary
 138
 139     my $letters = GetLettersAvailableForALibrary(
 140         {
 141             branchcode => 'CPL', # '' for default
 142             module => 'circulation',
 143         }
 144     );
 145
 146     Return an arrayref of letters, sorted by name.
 147     If a specific letter exist for the given branchcode, it will be retrieve.
 148     Otherwise the default letter will be.
 149
 150 =cut
 151
 152 sub GetLettersAvailableForALibrary {
 153     my ($filters)  = @_;
 154     my $branchcode = $filters->{branchcode};
 155     my $module     = $filters->{module};
 156
 157     croak "module should be provided" unless $module;
 158
 159     my $dbh             = C4::Context->dbh;
 160     my $default_letters = $dbh->selectall_arrayref(
 161         q|
 162             SELECT module, code, branchcode, name
 163             FROM letter
 164             WHERE 1
 165         |
 166           . q| AND branchcode = ''|
 167           . ( $module ? q| AND module = ?| : q|| )
 168           . q| ORDER BY name|, { Slice => {} }
 169         , ( $module ? $module : () )
 170     );
 171
 172     my $specific_letters;
 173     if ($branchcode) {
 174         $specific_letters = $dbh->selectall_arrayref(
 175             q|
 176                 SELECT module, code, branchcode, name
 177                 FROM letter
 178                 WHERE 1
 179             |
 180               . q| AND branchcode = ?|
 181               . ( $module ? q| AND module = ?| : q|| )
 182               . q| ORDER BY name|, { Slice => {} }
 183             , $branchcode
 184             , ( $module ? $module : () )
 185         );
 186     }
 187
 188     my %letters;
 189     for my $l (@$default_letters) {
 190         $letters{ $l->{code} } = $l;
 191     }
 192     for my $l (@$specific_letters) {
 193         # Overwrite the default letter with the specific one.
 194         $letters{ $l->{code} } = $l;
 195     }
 196
 197     return [ map { $letters{$_} }
 198           sort { $letters{$a}->{name} cmp $letters{$b}->{name} }
 199           keys %letters ];
 200
 201 }
 202
 203 # FIXME: using our here means that a Plack server will need to be
 204 #        restarted fairly regularly when working with this routine.
 205 #        A better option would be to use Koha::Cache and use a cache
 206 #        that actually works in a persistent environment, but as a
 207 #        short-term fix, our will work.
 208 our %letter;
 209 sub getletter {
 210     my ( $module, $code, $branchcode, $message_transport_type ) = @_;
 211     $message_transport_type //= '%';
 212
 213     if ( C4::Context->preference('IndependentBranches')
 214             and $branchcode
 215             and C4::Context->userenv ) {
 216
 217         $branchcode = C4::Context->userenv->{'branch'};
 218     }
 219     $branchcode //= '';
 220
 221     if ( my $l = $letter{$module}{$code}{$branchcode}{$message_transport_type} ) {
 222         return { %$l }; # deep copy
 223     }
 224
 225     my $dbh = C4::Context->dbh;
 226     my $sth = $dbh->prepare(q{
 227         SELECT *
 228         FROM letter
 229         WHERE module=? AND code=? AND (branchcode = ? OR branchcode = '')
 230         AND message_transport_type LIKE ?
 231         ORDER BY branchcode DESC LIMIT 1
 232     });
 233     $sth->execute( $module, $code, $branchcode, $message_transport_type );
 234     my $line = $sth->fetchrow_hashref
 235       or return;
 236     $line->{'content-type'} = 'text/html; charset="UTF-8"' if $line->{is_html};
 237     $letter{$module}{$code}{$branchcode}{$message_transport_type} = $line;
 238     return { %$line };
 239 }
 240
 241
 242 =head2 DelLetter
 243
 244     DelLetter(
 245         {
 246             branchcode => 'CPL',
 247             module => 'circulation',
 248             code => 'my code',
 249             [ mtt => 'email', ]
 250         }
 251     );
 252
 253     Delete the letter. The mtt parameter is facultative.
 254     If not given, all templates mathing the other parameters will be removed.
 255
 256 =cut
 257
 258 sub DelLetter {
 259     my ($params)   = @_;
 260     my $branchcode = $params->{branchcode};
 261     my $module     = $params->{module};
 262     my $code       = $params->{code};
 263     my $mtt        = $params->{mtt};
 264     my $dbh        = C4::Context->dbh;
 265     $dbh->do(q|
 266         DELETE FROM letter
 267         WHERE branchcode = ?
 268           AND module = ?
 269           AND code = ?
 270     | . ( $mtt ? q| AND message_transport_type = ?| : q|| )
 271     , undef, $branchcode, $module, $code, ( $mtt ? $mtt : () ) );
 272 }
 273
 274 =head2 addalert ($borrowernumber, $type, $externalid)
 275
 276     parameters :
 277     - $borrowernumber : the number of the borrower subscribing to the alert
 278     - $type : the type of alert.
 279     - $externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid.
 280
 281     create an alert and return the alertid (primary key)
 282
 283 =cut
 284
 285 sub addalert {
 286     my ( $borrowernumber, $type, $externalid ) = @_;
 287     my $dbh = C4::Context->dbh;
 288     my $sth =
 289       $dbh->prepare(
 290         "insert into alert (borrowernumber, type, externalid) values (?,?,?)");
 291     $sth->execute( $borrowernumber, $type, $externalid );
 292
 293     # get the alert number newly created and return it
 294     my $alertid = $dbh->{'mysql_insertid'};
 295     return $alertid;
 296 }
 297
 298 =head2 delalert ($alertid)
 299
 300     parameters :
 301     - alertid : the alert id
 302     deletes the alert
 303
 304 =cut
 305
 306 sub delalert {
 307     my $alertid = shift or die "delalert() called without valid argument (alertid)";    # it's gonna die anyway.
 308     $debug and warn "delalert: deleting alertid $alertid";
 309     my $sth = C4::Context->dbh->prepare("delete from alert where alertid=?");
 310     $sth->execute($alertid);
 311 }
 312
 313 =head2 getalert ([$borrowernumber], [$type], [$externalid])
 314
 315     parameters :
 316     - $borrowernumber : the number of the borrower subscribing to the alert
 317     - $type : the type of alert.
 318     - $externalid : the primary key of the object to put alert on. For issues, the alert is made on subscriptionid.
 319     all parameters NON mandatory. If a parameter is omitted, the query is done without the corresponding parameter. For example, without $externalid, returns all alerts for a borrower on a topic.
 320
 321 =cut
 322
 323 sub getalert {
 324     my ( $borrowernumber, $type, $externalid ) = @_;
 325     my $dbh   = C4::Context->dbh;
 326     my $query = "SELECT a.*, b.branchcode FROM alert a JOIN borrowers b USING(borrowernumber) WHERE";
 327     my @bind;
 328     if ($borrowernumber and $borrowernumber =~ /^\d+$/) {
 329         $query .= " borrowernumber=? AND ";
 330         push @bind, $borrowernumber;
 331     }
 332     if ($type) {
 333         $query .= " type=? AND ";
 334         push @bind, $type;
 335     }
 336     if ($externalid) {
 337         $query .= " externalid=? AND ";
 338         push @bind, $externalid;
 339     }
 340     $query =~ s/ AND $//;
 341     my $sth = $dbh->prepare($query);
 342     $sth->execute(@bind);
 343     return $sth->fetchall_arrayref({});
 344 }
 345
 346 =head2 findrelatedto($type, $externalid)
 347
 348     parameters :
 349     - $type : the type of alert
 350     - $externalid : the id of the "object" to query
 351
 352     In the table alert, a "id" is stored in the externalid field. This "id" is related to another table, depending on the type of the alert.
 353     When type=issue, the id is related to a subscriptionid and this sub returns the name of the biblio.
 354
 355 =cut
 356
 357 # outmoded POD:
 358 # When type=virtual, the id is related to a virtual shelf and this sub returns the name of the sub
 359
 360 sub findrelatedto {
 361     my $type       = shift or return;
 362     my $externalid = shift or return;
 363     my $q = ($type eq 'issue'   ) ?
 364 "select title as result from subscription left join biblio on subscription.biblionumber=biblio.biblionumber where subscriptionid=?" :
 365             ($type eq 'borrower') ?
 366 "select concat(firstname,' ',surname) from borrowers where borrowernumber=?" : undef;
 367     unless ($q) {
 368         warn "findrelatedto(): Illegal type '$type'";
 369         return;
 370     }
 371     my $sth = C4::Context->dbh->prepare($q);
 372     $sth->execute($externalid);
 373     my ($result) = $sth->fetchrow;
 374     return $result;
 375 }
 376
 377 =head2 SendAlerts
 378
 379     parameters :
 380     - $type : the type of alert
 381     - $externalid : the id of the "object" to query
 382     - $letter_code : the letter to send.
 383
 384     send an alert to all borrowers having put an alert on a given subject.
 385
 386 =cut
 387
 388 sub SendAlerts {
 389     my ( $type, $externalid, $letter_code ) = @_;
 390     my $dbh = C4::Context->dbh;
 391     if ( $type eq 'issue' ) {
 392
 393         # prepare the letter...
 394         # search the subscriptionid
 395         my $sth =
 396           $dbh->prepare(
 397             "SELECT subscriptionid FROM serial WHERE serialid=?");
 398         $sth->execute($externalid);
 399         my ($subscriptionid) = $sth->fetchrow
 400           or warn( "No subscription for '$externalid'" ),
 401              return;
 402
 403         # search the biblionumber
 404         $sth =
 405           $dbh->prepare(
 406             "SELECT biblionumber FROM subscription WHERE subscriptionid=?");
 407         $sth->execute($subscriptionid);
 408         my ($biblionumber) = $sth->fetchrow
 409           or warn( "No biblionumber for '$subscriptionid'" ),
 410              return;
 411
 412         my %letter;
 413         # find the list of borrowers to alert
 414         my $alerts = getalert( '', 'issue', $subscriptionid );
 415         foreach (@$alerts) {
 416             my $borinfo = C4::Members::GetMember('borrowernumber' => $_->{'borrowernumber'});
 417             my $email = $borinfo->{email} or next;
 418
 419 #                    warn "sending issues...";
 420             my $userenv = C4::Context->userenv;
 421             my $branchdetails = GetBranchDetail($_->{'branchcode'});
 422             my $letter = GetPreparedLetter (
 423                 module => 'serial',
 424                 letter_code => $letter_code,
 425                 branchcode => $userenv->{branch},
 426                 tables => {
 427                     'branches'    => $_->{branchcode},
 428                     'biblio'      => $biblionumber,
 429                     'biblioitems' => $biblionumber,
 430                     'borrowers'   => $borinfo,
 431                     'subscription' => $subscriptionid,
 432                     'serial' => $externalid,
 433                 },
 434                 want_librarian => 1,
 435             ) or return;
 436
 437             # ... then send mail
 438             my $message = Koha::Email->new();
 439             my %mail = $message->create_message_headers(
 440                 {
 441                     to      => $email,
 442                     from    => $branchdetails->{'branchemail'},
 443                     replyto => $branchdetails->{'branchreplyto'},
 444                     sender  => $branchdetails->{'branchreturnpath'},
 445                     subject => Encode::encode( "UTF-8", "" . $letter->{title} ),
 446                     message => $letter->{'is_html'}
 447                                 ? _wrap_html( Encode::encode( "UTF-8", $letter->{'content'} ),
 448                                               Encode::encode( "UTF-8", "" . $letter->{'title'} ))
 449                                 : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
 450                     contenttype => $letter->{'is_html'}
 451                                     ? 'text/html; charset="utf-8"'
 452                                     : 'text/plain; charset="utf-8"',
 453                 }
 454             );
 455             sendmail(%mail) or carp $Mail::Sendmail::error;
 456         }
 457     }
 458     elsif ( $type eq 'claimacquisition' or $type eq 'claimissues' ) {
 459
 460         # prepare the letter...
 461         # search the biblionumber
 462         my $strsth =  $type eq 'claimacquisition'
 463             ? qq{
 464             SELECT aqorders.*,aqbasket.*,biblio.*,biblioitems.*
 465             FROM aqorders
 466             LEFT JOIN aqbasket ON aqbasket.basketno=aqorders.basketno
 467             LEFT JOIN biblio ON aqorders.biblionumber=biblio.biblionumber
 468             LEFT JOIN biblioitems ON aqorders.biblionumber=biblioitems.biblionumber
 469             WHERE aqorders.ordernumber IN (
 470             }
 471             : qq{
 472             SELECT serial.*,subscription.*, biblio.*, aqbooksellers.*,
 473             aqbooksellers.id AS booksellerid
 474             FROM serial
 475             LEFT JOIN subscription ON serial.subscriptionid=subscription.subscriptionid
 476             LEFT JOIN biblio ON serial.biblionumber=biblio.biblionumber
 477             LEFT JOIN aqbooksellers ON subscription.aqbooksellerid=aqbooksellers.id
 478             WHERE serial.serialid IN (
 479             };
 480
 481         if (!@$externalid){
 482             carp "No Order seleted";
 483             return { error => "no_order_seleted" };
 484         }
 485
 486         $strsth .= join( ",", @$externalid ) . ")";
 487         my $sthorders = $dbh->prepare($strsth);
 488         $sthorders->execute;
 489         my $dataorders = $sthorders->fetchall_arrayref( {} );
 490
 491         my $sthbookseller =
 492           $dbh->prepare("select * from aqbooksellers where id=?");
 493         $sthbookseller->execute( $dataorders->[0]->{booksellerid} );
 494         my $databookseller = $sthbookseller->fetchrow_hashref;
 495         my $addressee =  $type eq 'claimacquisition' ? 'acqprimary' : 'serialsprimary';
 496         my $sthcontact =
 497           $dbh->prepare("SELECT * FROM aqcontacts WHERE booksellerid=? AND $type=1 ORDER BY $addressee DESC");
 498         $sthcontact->execute( $dataorders->[0]->{booksellerid} );
 499         my $datacontact = $sthcontact->fetchrow_hashref;
 500
 501         my @email;
 502         my @cc;
 503         push @email, $databookseller->{bookselleremail} if $databookseller->{bookselleremail};
 504         push @email, $datacontact->{email}           if ( $datacontact && $datacontact->{email} );
 505         unless (@email) {
 506             warn "Bookseller $dataorders->[0]->{booksellerid} without emails";
 507             return { error => "no_email" };
 508         }
 509         my $addlcontact;
 510         while ($addlcontact = $sthcontact->fetchrow_hashref) {
 511             push @cc, $addlcontact->{email} if ( $addlcontact && $addlcontact->{email} );
 512         }
 513
 514         my $userenv = C4::Context->userenv;
 515         my $letter = GetPreparedLetter (
 516             module => $type,
 517             letter_code => $letter_code,
 518             branchcode => $userenv->{branch},
 519             tables => {
 520                 'branches'    => $userenv->{branch},
 521                 'aqbooksellers' => $databookseller,
 522                 'aqcontacts'    => $datacontact,
 523             },
 524             repeat => $dataorders,
 525             want_librarian => 1,
 526         ) or return;
 527
 528         # Remove the order tag
 529         $letter->{content} =~ s/<order>(.*?)<\/order>/$1/gxms;
 530
 531         # ... then send mail
 532         my %mail = (
 533             To => join( ',', @email),
 534             Cc             => join( ',', @cc),
 535             From           => $userenv->{emailaddress},
 536             Subject        => Encode::encode( "UTF-8", "" . $letter->{title} ),
 537             Message => $letter->{'is_html'}
 538                             ? _wrap_html( Encode::encode( "UTF-8", $letter->{'content'} ),
 539                                           Encode::encode( "UTF-8", "" . $letter->{'title'} ))
 540                             : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
 541             'Content-Type' => $letter->{'is_html'}
 542                                 ? 'text/html; charset="utf-8"'
 543                                 : 'text/plain; charset="utf-8"',
 544         );
 545
 546         $mail{'Reply-to'} = C4::Context->preference('ReplytoDefault')
 547           if C4::Context->preference('ReplytoDefault');
 548         $mail{'Sender'} = C4::Context->preference('ReturnpathDefault')
 549           if C4::Context->preference('ReturnpathDefault');
 550
 551         unless ( sendmail(%mail) ) {
 552             carp $Mail::Sendmail::error;
 553             return { error => $Mail::Sendmail::error };
 554         }
 555
 556         logaction(
 557             "ACQUISITION",
 558             $type eq 'claimissues' ? "CLAIM ISSUE" : "ACQUISITION CLAIM",
 559             undef,
 560             "To="
 561                 . join( ',', @email )
 562                 . " Title="
 563                 . $letter->{title}
 564                 . " Content="
 565                 . $letter->{content}
 566         ) if C4::Context->preference("LetterLog");
 567     }
 568    # send an "account details" notice to a newly created user
 569     elsif ( $type eq 'members' ) {
 570         my $branchdetails = GetBranchDetail($externalid->{'branchcode'});
 571         my $letter = GetPreparedLetter (
 572             module => 'members',
 573             letter_code => $letter_code,
 574             branchcode => $externalid->{'branchcode'},
 575             tables => {
 576                 'branches'    => $branchdetails,
 577                 'borrowers' => $externalid->{'borrowernumber'},
 578             },
 579             substitute => { 'borrowers.password' => $externalid->{'password'} },
 580             want_librarian => 1,
 581         ) or return;
 582         return { error => "no_email" } unless $externalid->{'emailaddr'};
 583         my $email = Koha::Email->new();
 584         my %mail  = $email->create_message_headers(
 585             {
 586                 to      => $externalid->{'emailaddr'},
 587                 from    => $branchdetails->{'branchemail'},
 588                 replyto => $branchdetails->{'branchreplyto'},
 589                 sender  => $branchdetails->{'branchreturnpath'},
 590                 subject => Encode::encode( "UTF-8", "" . $letter->{'title'} ),
 591                 message => $letter->{'is_html'}
 592                             ? _wrap_html( Encode::encode( "UTF-8", $letter->{'content'} ),
 593                                           Encode::encode( "UTF-8", "" . $letter->{'title'}  ) )
 594                             : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
 595                 contenttype => $letter->{'is_html'}
 596                                 ? 'text/html; charset="utf-8"'
 597                                 : 'text/plain; charset="utf-8"',
 598             }
 599         );
 600         sendmail(%mail) or carp $Mail::Sendmail::error;
 601     }
 602 }
 603
 604 =head2 GetPreparedLetter( %params )
 605
 606     %params hash:
 607       module => letter module, mandatory
 608       letter_code => letter code, mandatory
 609       branchcode => for letter selection, if missing default system letter taken
 610       tables => a hashref with table names as keys. Values are either:
 611         - a scalar - primary key value
 612         - an arrayref - primary key values
 613         - a hashref - full record
 614       substitute => custom substitution key/value pairs
 615       repeat => records to be substituted on consecutive lines:
 616         - an arrayref - tries to guess what needs substituting by
 617           taking remaining << >> tokensr; not recommended
 618         - a hashref token => @tables - replaces <token> << >> << >> </token>
 619           subtemplate for each @tables row; table is a hashref as above
 620       want_librarian => boolean,  if set to true triggers librarian details
 621         substitution from the userenv
 622     Return value:
 623       letter fields hashref (title & content useful)
 624
 625 =cut
 626
 627 sub GetPreparedLetter {
 628     my %params = @_;
 629
 630     my $module      = $params{module} or croak "No module";
 631     my $letter_code = $params{letter_code} or croak "No letter_code";
 632     my $branchcode  = $params{branchcode} || '';
 633     my $mtt         = $params{message_transport_type} || 'email';
 634
 635     my $letter = getletter( $module, $letter_code, $branchcode, $mtt )
 636         or warn( "No $module $letter_code letter transported by " . $mtt ),
 637             return;
 638
 639     my $tables = $params{tables};
 640     my $substitute = $params{substitute};
 641     my $repeat = $params{repeat};
 642     $tables || $substitute || $repeat
 643       or carp( "ERROR: nothing to substitute - both 'tables' and 'substitute' are empty" ),
 644          return;
 645     my $want_librarian = $params{want_librarian};
 646
 647     if ($substitute) {
 648         while ( my ($token, $val) = each %$substitute ) {
 649             if ( $token eq 'items.content' ) {
 650                 $val =~ s|\n|<br/>|g if $letter->{is_html};
 651             }
 652
 653             $letter->{title} =~ s/<<$token>>/$val/g;
 654             $letter->{content} =~ s/<<$token>>/$val/g;
 655        }
 656     }
 657
 658     my $OPACBaseURL = C4::Context->preference('OPACBaseURL');
 659     $letter->{content} =~ s/<<OPACBaseURL>>/$OPACBaseURL/go;
 660
 661     if ($want_librarian) {
 662         # parsing librarian name
 663         my $userenv = C4::Context->userenv;
 664         $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/go;
 665         $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/go;
 666         $letter->{content} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/go;
 667     }
 668
 669     my ($repeat_no_enclosing_tags, $repeat_enclosing_tags);
 670
 671     if ($repeat) {
 672         if (ref ($repeat) eq 'ARRAY' ) {
 673             $repeat_no_enclosing_tags = $repeat;
 674         } else {
 675             $repeat_enclosing_tags = $repeat;
 676         }
 677     }
 678
 679     if ($repeat_enclosing_tags) {
 680         while ( my ($tag, $tag_tables) = each %$repeat_enclosing_tags ) {
 681             if ( $letter->{content} =~ m!<$tag>(.*)</$tag>!s ) {
 682                 my $subcontent = $1;
 683                 my @lines = map {
 684                     my %subletter = ( title => '', content => $subcontent );
 685                     _substitute_tables( \%subletter, $_ );
 686                     $subletter{content};
 687                 } @$tag_tables;
 688                 $letter->{content} =~ s!<$tag>.*</$tag>!join( "\n", @lines )!se;
 689             }
 690         }
 691     }
 692
 693     if ($tables) {
 694         _substitute_tables( $letter, $tables );
 695     }
 696
 697     if ($repeat_no_enclosing_tags) {
 698         if ( $letter->{content} =~ m/[^\n]*<<.*>>[^\n]*/so ) {
 699             my $line = $&;
 700             my $i = 1;
 701             my @lines = map {
 702                 my $c = $line;
 703                 $c =~ s/<<count>>/$i/go;
 704                 foreach my $field ( keys %{$_} ) {
 705                     $c =~ s/(<<[^\.]+.$field>>)/$_->{$field}/;
 706                 }
 707                 $i++;
 708                 $c;
 709             } @$repeat_no_enclosing_tags;
 710
 711             my $replaceby = join( "\n", @lines );
 712             $letter->{content} =~ s/\Q$line\E/$replaceby/s;
 713         }
 714     }
 715
 716     $letter->{content} =~ s/<<\S*>>//go; #remove any stragglers
 717 #   $letter->{content} =~ s/<<[^>]*>>//go;
 718
 719     return $letter;
 720 }
 721
 722 sub _substitute_tables {
 723     my ( $letter, $tables ) = @_;
 724     while ( my ($table, $param) = each %$tables ) {
 725         next unless $param;
 726
 727         my $ref = ref $param;
 728
 729         my $values;
 730         if ($ref && $ref eq 'HASH') {
 731             $values = $param;
 732         }
 733         else {
 734             my $sth = _parseletter_sth($table);
 735             unless ($sth) {
 736                 warn "_parseletter_sth('$table') failed to return a valid sth.  No substitution will be done for that table.";
 737                 return;
 738             }
 739             $sth->execute( $ref ? @$param : $param );
 740
 741             $values = $sth->fetchrow_hashref;
 742             $sth->finish();
 743         }
 744
 745         _parseletter ( $letter, $table, $values );
 746     }
 747 }
 748
 749 sub _parseletter_sth {
 750     my $table = shift;
 751     my $sth;
 752     unless ($table) {
 753         carp "ERROR: _parseletter_sth() called without argument (table)";
 754         return;
 755     }
 756     # NOTE: we used to check whether we had a statement handle cached in
 757     #       a %handles module-level variable. This was a dumb move and
 758     #       broke things for the rest of us. prepare_cached is a better
 759     #       way to cache statement handles anyway.
 760     my $query =
 761     ($table eq 'biblio'       ) ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 762     ($table eq 'biblioitems'  ) ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 763     ($table eq 'items'        ) ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 764     ($table eq 'issues'       ) ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 765     ($table eq 'old_issues'   ) ? "SELECT * FROM $table WHERE     itemnumber = ? ORDER BY timestamp DESC LIMIT 1"  :
 766     ($table eq 'reserves'     ) ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?"             :
 767     ($table eq 'borrowers'    ) ? "SELECT * FROM $table WHERE borrowernumber = ?"                                  :
 768     ($table eq 'branches'     ) ? "SELECT * FROM $table WHERE     branchcode = ?"                                  :
 769     ($table eq 'suggestions'  ) ? "SELECT * FROM $table WHERE   suggestionid = ?"                                  :
 770     ($table eq 'aqbooksellers') ? "SELECT * FROM $table WHERE             id = ?"                                  :
 771     ($table eq 'aqorders'     ) ? "SELECT * FROM $table WHERE    ordernumber = ?"                                  :
 772     ($table eq 'opac_news'    ) ? "SELECT * FROM $table WHERE          idnew = ?"                                  :
 773     ($table eq 'borrower_modifications') ? "SELECT * FROM $table WHERE verification_token = ?" :
 774     ($table eq 'subscription') ? "SELECT * FROM $table WHERE subscriptionid = ?" :
 775     ($table eq 'serial') ? "SELECT * FROM $table WHERE serialid = ?" :
 776     undef ;
 777     unless ($query) {
 778         warn "ERROR: No _parseletter_sth query for table '$table'";
 779         return;     # nothing to get
 780     }
 781     unless ($sth = C4::Context->dbh->prepare_cached($query)) {
 782         warn "ERROR: Failed to prepare query: '$query'";
 783         return;
 784     }
 785     return $sth;    # now cache is populated for that $table
 786 }
 787
 788 =head2 _parseletter($letter, $table, $values)
 789
 790     parameters :
 791     - $letter : a hash to letter fields (title & content useful)
 792     - $table : the Koha table to parse.
 793     - $values : table record hashref
 794     parse all fields from a table, and replace values in title & content with the appropriate value
 795     (not exported sub, used only internally)
 796
 797 =cut
 798
 799 sub _parseletter {
 800     my ( $letter, $table, $values ) = @_;
 801
 802     if ( $table eq 'borrowers' && $values->{'dateexpiry'} ){
 803         $values->{'dateexpiry'} = format_sqldatetime( $values->{'dateexpiry'} );
 804     }
 805
 806     if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
 807         my @waitingdate = split /-/, $values->{'waitingdate'};
 808
 809         $values->{'expirationdate'} = '';
 810         if( C4::Context->preference('ExpireReservesMaxPickUpDelay') &&
 811         C4::Context->preference('ReservesMaxPickUpDelay') ) {
 812             my $dt = dt_from_string();
 813             $dt->add( days => C4::Context->preference('ReservesMaxPickUpDelay') );
 814             $values->{'expirationdate'} = output_pref({ dt => $dt, dateonly => 1 });
 815         }
 816
 817         $values->{'waitingdate'} = output_pref({ dt => dt_from_string( $values->{'waitingdate'} ), dateonly => 1 });
 818
 819     }
 820
 821     if ($letter->{content} && $letter->{content} =~ /<<today>>/) {
 822         my $todaysdate = output_pref( DateTime->now() );
 823         $letter->{content} =~ s/<<today>>/$todaysdate/go;
 824     }
 825
 826     while ( my ($field, $val) = each %$values ) {
 827         $val =~ s/\p{P}$// if $val && $table=~/biblio/;
 828             #BZ 9886: Assuming that we want to eliminate ISBD punctuation here
 829             #Therefore adding the test on biblio. This includes biblioitems,
 830             #but excludes items. Removed unneeded global and lookahead.
 831
 832         $val = GetAuthorisedValueByCode ('ROADTYPE', $val, 0) if $table=~/^borrowers$/ && $field=~/^streettype$/;
 833
 834         # Dates replacement
 835         my $replacedby   = defined ($val) ? $val : '';
 836         if (    $replacedby
 837             and not $replacedby =~ m|0000-00-00|
 838             and not $replacedby =~ m|9999-12-31|
 839             and $replacedby =~ m|^\d{4}-\d{2}-\d{2}( \d{2}:\d{2}:\d{2})?$| )
 840         {
 841             # If the value is XXXX-YY-ZZ[ AA:BB:CC] we assume it is a date
 842             my $dateonly = defined $1 ? 0 : 1; #$1 refers to the capture group wrapped in parentheses. In this case, that's the hours, minutes, seconds.
 843             my $re_dateonly_filter = qr{ $field( \s* \| \s* dateonly\s*)?>> }xms;
 844
 845             for my $letter_field ( qw( title content ) ) {
 846                 my $filter_string_used = q{};
 847                 if ( $letter->{ $letter_field } =~ $re_dateonly_filter ) {
 848                     # We overwrite $dateonly if the filter exists and we have a time in the datetime
 849                     $filter_string_used = $1 || q{};
 850                     $dateonly = $1 unless $dateonly;
 851                 }
 852                 eval {
 853                     $replacedby = output_pref({ dt => dt_from_string( $replacedby ), dateonly => $dateonly });
 854                 };
 855
 856                 if ( $letter->{ $letter_field } ) {
 857                     $letter->{ $letter_field } =~ s/\Q<<$table.$field$filter_string_used>>\E/$replacedby/g;
 858                     $letter->{ $letter_field } =~ s/\Q<<$field$filter_string_used>>\E/$replacedby/g;
 859                 }
 860             }
 861         }
 862         # Other fields replacement
 863         else {
 864             for my $letter_field ( qw( title content ) ) {
 865                 if ( $letter->{ $letter_field } ) {
 866                     $letter->{ $letter_field }   =~ s/<<$table.$field>>/$replacedby/g;
 867                     $letter->{ $letter_field }   =~ s/<<$field>>/$replacedby/g;
 868                 }
 869             }
 870         }
 871     }
 872
 873     if ($table eq 'borrowers' && $letter->{content}) {
 874         if ( my $attributes = GetBorrowerAttributes($values->{borrowernumber}) ) {
 875             my %attr;
 876             foreach (@$attributes) {
 877                 my $code = $_->{code};
 878                 my $val  = $_->{value_description} || $_->{value};
 879                 $val =~ s/\p{P}(?=$)//g if $val;
 880                 next unless $val gt '';
 881                 $attr{$code} ||= [];
 882                 push @{ $attr{$code} }, $val;
 883             }
 884             while ( my ($code, $val_ar) = each %attr ) {
 885                 my $replacefield = "<<borrower-attribute:$code>>";
 886                 my $replacedby   = join ',', @$val_ar;
 887                 $letter->{content} =~ s/$replacefield/$replacedby/g;
 888             }
 889         }
 890     }
 891     return $letter;
 892 }
 893
 894 =head2 EnqueueLetter
 895
 896   my $success = EnqueueLetter( { letter => $letter,
 897         borrowernumber => '12', message_transport_type => 'email' } )
 898
 899 places a letter in the message_queue database table, which will
 900 eventually get processed (sent) by the process_message_queue.pl
 901 cronjob when it calls SendQueuedMessages.
 902
 903 return message_id on success
 904
 905 =cut
 906
 907 sub EnqueueLetter {
 908     my $params = shift or return;
 909
 910     return unless exists $params->{'letter'};
 911 #   return unless exists $params->{'borrowernumber'};
 912     return unless exists $params->{'message_transport_type'};
 913
 914     my $content = $params->{letter}->{content};
 915     $content =~ s/\s+//g if(defined $content);
 916     if ( not defined $content or $content eq '' ) {
 917         warn "Trying to add an empty message to the message queue" if $debug;
 918         return;
 919     }
 920
 921     # If we have any attachments we should encode then into the body.
 922     if ( $params->{'attachments'} ) {
 923         $params->{'letter'} = _add_attachments(
 924             {   letter      => $params->{'letter'},
 925                 attachments => $params->{'attachments'},
 926                 message     => MIME::Lite->new( Type => 'multipart/mixed' ),
 927             }
 928         );
 929     }
 930
 931     my $dbh       = C4::Context->dbh();
 932     my $statement = << 'ENDSQL';
 933 INSERT INTO message_queue
 934 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type )
 935 VALUES
 936 ( ?,              ?,       ?,       ?,        ?,           ?,                      ?,      NOW(),       ?,          ?,            ? )
 937 ENDSQL
 938
 939     my $sth    = $dbh->prepare($statement);
 940     my $result = $sth->execute(
 941         $params->{'borrowernumber'},              # borrowernumber
 942         $params->{'letter'}->{'title'},           # subject
 943         $params->{'letter'}->{'content'},         # content
 944         $params->{'letter'}->{'metadata'} || '',  # metadata
 945         $params->{'letter'}->{'code'}     || '',  # letter_code
 946         $params->{'message_transport_type'},      # message_transport_type
 947         'pending',                                # status
 948         $params->{'to_address'},                  # to_address
 949         $params->{'from_address'},                # from_address
 950         $params->{'letter'}->{'content-type'},    # content_type
 951     );
 952     return $dbh->last_insert_id(undef,undef,'message_queue', undef);
 953 }
 954
 955 =head2 SendQueuedMessages ([$hashref])
 956
 957   my $sent = SendQueuedMessages( { verbose => 1 } );
 958
 959 sends all of the 'pending' items in the message queue.
 960
 961 returns number of messages sent.
 962
 963 =cut
 964
 965 sub SendQueuedMessages {
 966     my $params = shift;
 967
 968     my $unsent_messages = _get_unsent_messages();
 969     MESSAGE: foreach my $message ( @$unsent_messages ) {
 970         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
 971         warn sprintf( 'sending %s message to patron: %s',
 972                       $message->{'message_transport_type'},
 973                       $message->{'borrowernumber'} || 'Admin' )
 974           if $params->{'verbose'} or $debug;
 975         # This is just begging for subclassing
 976         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
 977         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
 978             _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
 979         }
 980         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
 981             _send_message_by_sms( $message );
 982         }
 983     }
 984     return scalar( @$unsent_messages );
 985 }
 986
 987 =head2 GetRSSMessages
 988
 989   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
 990
 991 returns a listref of all queued RSS messages for a particular person.
 992
 993 =cut
 994
 995 sub GetRSSMessages {
 996     my $params = shift;
 997
 998     return unless $params;
 999     return unless ref $params;
1000     return unless $params->{'borrowernumber'};
1001
1002     return _get_unsent_messages( { message_transport_type => 'rss',
1003                                    limit                  => $params->{'limit'},
1004                                    borrowernumber         => $params->{'borrowernumber'}, } );
1005 }
1006
1007 =head2 GetPrintMessages
1008
1009   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
1010
1011 Returns a arrayref of all queued print messages (optionally, for a particular
1012 person).
1013
1014 =cut
1015
1016 sub GetPrintMessages {
1017     my $params = shift || {};
1018
1019     return _get_unsent_messages( { message_transport_type => 'print',
1020                                    borrowernumber         => $params->{'borrowernumber'},
1021                                  } );
1022 }
1023
1024 =head2 GetQueuedMessages ([$hashref])
1025
1026   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
1027
1028 fetches messages out of the message queue.
1029
1030 returns:
1031 list of hashes, each has represents a message in the message queue.
1032
1033 =cut
1034
1035 sub GetQueuedMessages {
1036     my $params = shift;
1037
1038     my $dbh = C4::Context->dbh();
1039     my $statement = << 'ENDSQL';
1040 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued
1041 FROM message_queue
1042 ENDSQL
1043
1044     my @query_params;
1045     my @whereclauses;
1046     if ( exists $params->{'borrowernumber'} ) {
1047         push @whereclauses, ' borrowernumber = ? ';
1048         push @query_params, $params->{'borrowernumber'};
1049     }
1050
1051     if ( @whereclauses ) {
1052         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
1053     }
1054
1055     if ( defined $params->{'limit'} ) {
1056         $statement .= ' LIMIT ? ';
1057         push @query_params, $params->{'limit'};
1058     }
1059
1060     my $sth = $dbh->prepare( $statement );
1061     my $result = $sth->execute( @query_params );
1062     return $sth->fetchall_arrayref({});
1063 }
1064
1065 =head2 GetMessageTransportTypes
1066
1067   my @mtt = GetMessageTransportTypes();
1068
1069   returns an arrayref of transport types
1070
1071 =cut
1072
1073 sub GetMessageTransportTypes {
1074     my $dbh = C4::Context->dbh();
1075     my $mtts = $dbh->selectcol_arrayref("
1076         SELECT message_transport_type
1077         FROM message_transport_types
1078         ORDER BY message_transport_type
1079     ");
1080     return $mtts;
1081 }
1082
1083 =head2 _add_attachements
1084
1085 named parameters:
1086 letter - the standard letter hashref
1087 attachments - listref of attachments. each attachment is a hashref of:
1088   type - the mime type, like 'text/plain'
1089   content - the actual attachment
1090   filename - the name of the attachment.
1091 message - a MIME::Lite object to attach these to.
1092
1093 returns your letter object, with the content updated.
1094
1095 =cut
1096
1097 sub _add_attachments {
1098     my $params = shift;
1099
1100     my $letter = $params->{'letter'};
1101     my $attachments = $params->{'attachments'};
1102     return $letter unless @$attachments;
1103     my $message = $params->{'message'};
1104
1105     # First, we have to put the body in as the first attachment
1106     $message->attach(
1107         Type => $letter->{'content-type'} || 'TEXT',
1108         Data => $letter->{'is_html'}
1109             ? _wrap_html($letter->{'content'}, $letter->{'title'})
1110             : $letter->{'content'},
1111     );
1112
1113     foreach my $attachment ( @$attachments ) {
1114         $message->attach(
1115             Type     => $attachment->{'type'},
1116             Data     => $attachment->{'content'},
1117             Filename => $attachment->{'filename'},
1118         );
1119     }
1120     # we're forcing list context here to get the header, not the count back from grep.
1121     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
1122     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
1123     $letter->{'content'} = $message->body_as_string;
1124
1125     return $letter;
1126
1127 }
1128
1129 sub _get_unsent_messages {
1130     my $params = shift;
1131
1132     my $dbh = C4::Context->dbh();
1133     my $statement = << 'ENDSQL';
1134 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
1135   FROM message_queue mq
1136   LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
1137  WHERE status = ?
1138 ENDSQL
1139
1140     my @query_params = ('pending');
1141     if ( ref $params ) {
1142         if ( $params->{'message_transport_type'} ) {
1143             $statement .= ' AND message_transport_type = ? ';
1144             push @query_params, $params->{'message_transport_type'};
1145         }
1146         if ( $params->{'borrowernumber'} ) {
1147             $statement .= ' AND borrowernumber = ? ';
1148             push @query_params, $params->{'borrowernumber'};
1149         }
1150         if ( $params->{'limit'} ) {
1151             $statement .= ' limit ? ';
1152             push @query_params, $params->{'limit'};
1153         }
1154     }
1155
1156     $debug and warn "_get_unsent_messages SQL: $statement";
1157     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
1158     my $sth = $dbh->prepare( $statement );
1159     my $result = $sth->execute( @query_params );
1160     return $sth->fetchall_arrayref({});
1161 }
1162
1163 sub _send_message_by_email {
1164     my $message = shift or return;
1165     my ($username, $password, $method) = @_;
1166
1167     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
1168     my $to_address = $message->{'to_address'};
1169     unless ($to_address) {
1170         unless ($member) {
1171             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
1172             _set_message_status( { message_id => $message->{'message_id'},
1173                                    status     => 'failed' } );
1174             return;
1175         }
1176         $to_address = C4::Members::GetNoticeEmailAddress( $message->{'borrowernumber'} );
1177         unless ($to_address) {
1178             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
1179             # warning too verbose for this more common case?
1180             _set_message_status( { message_id => $message->{'message_id'},
1181                                    status     => 'failed' } );
1182             return;
1183         }
1184     }
1185
1186     my $utf8   = decode('MIME-Header', $message->{'subject'} );
1187     $message->{subject}= encode('MIME-Header', $utf8);
1188     my $subject = encode('UTF-8', $message->{'subject'});
1189     my $content = encode('UTF-8', $message->{'content'});
1190     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
1191     my $is_html = $content_type =~ m/html/io;
1192     my $branch_email = undef;
1193     my $branch_replyto = undef;
1194     my $branch_returnpath = undef;
1195     if ($member){
1196         my $branchdetail = GetBranchDetail( $member->{'branchcode'} );
1197         $branch_email = $branchdetail->{'branchemail'};
1198         $branch_replyto = $branchdetail->{'branchreplyto'};
1199         $branch_returnpath = $branchdetail->{'branchreturnpath'};
1200     }
1201     my $email = Koha::Email->new();
1202     my %sendmail_params = $email->create_message_headers(
1203         {
1204             to      => $to_address,
1205             from    => $message->{'from_address'} || $branch_email,
1206             replyto => $branch_replyto,
1207             sender  => $branch_returnpath,
1208             subject => $subject,
1209             message => $is_html ? _wrap_html( $content, $subject ) : $content,
1210             contenttype => $content_type
1211         }
1212     );
1213
1214     $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
1215     if ( my $bcc = C4::Context->preference('OverdueNoticeBcc') ) {
1216        $sendmail_params{ Bcc } = $bcc;
1217     }
1218
1219     _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
1220     if ( sendmail( %sendmail_params ) ) {
1221         _set_message_status( { message_id => $message->{'message_id'},
1222                 status     => 'sent' } );
1223         return 1;
1224     } else {
1225         _set_message_status( { message_id => $message->{'message_id'},
1226                 status     => 'failed' } );
1227         carp $Mail::Sendmail::error;
1228         return;
1229     }
1230 }
1231
1232 sub _wrap_html {
1233     my ($content, $title) = @_;
1234
1235     my $css = C4::Context->preference("NoticeCSS") || '';
1236     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
1237     return <<EOS;
1238 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1239     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1240 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1241 <head>
1242 <title>$title</title>
1243 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1244 $css
1245 </head>
1246 <body>
1247 $content
1248 </body>
1249 </html>
1250 EOS
1251 }
1252
1253 sub _is_duplicate {
1254     my ( $message ) = @_;
1255     my $dbh = C4::Context->dbh;
1256     my $count = $dbh->selectrow_array(q|
1257         SELECT COUNT(*)
1258         FROM message_queue
1259         WHERE message_transport_type = ?
1260         AND borrowernumber = ?
1261         AND letter_code = ?
1262         AND CAST(time_queued AS date) = CAST(NOW() AS date)
1263         AND status="sent"
1264         AND content = ?
1265     |, {}, $message->{message_transport_type}, $message->{borrowernumber}, $message->{letter_code}, $message->{content} );
1266     return $count;
1267 }
1268
1269 sub _send_message_by_sms {
1270     my $message = shift or return;
1271     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
1272
1273     unless ( $member->{smsalertnumber} ) {
1274         _set_message_status( { message_id => $message->{'message_id'},
1275                                status     => 'failed' } );
1276         return;
1277     }
1278
1279     if ( _is_duplicate( $message ) ) {
1280         _set_message_status( { message_id => $message->{'message_id'},
1281                                status     => 'failed' } );
1282         return;
1283     }
1284
1285     my $success = C4::SMS->send_sms( { destination => $member->{'smsalertnumber'},
1286                                        message     => $message->{'content'},
1287                                      } );
1288     _set_message_status( { message_id => $message->{'message_id'},
1289                            status     => ($success ? 'sent' : 'failed') } );
1290     return $success;
1291 }
1292
1293 sub _update_message_to_address {
1294     my ($id, $to)= @_;
1295     my $dbh = C4::Context->dbh();
1296     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1297 }
1298
1299 sub _set_message_status {
1300     my $params = shift or return;
1301
1302     foreach my $required_parameter ( qw( message_id status ) ) {
1303         return unless exists $params->{ $required_parameter };
1304     }
1305
1306     my $dbh = C4::Context->dbh();
1307     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1308     my $sth = $dbh->prepare( $statement );
1309     my $result = $sth->execute( $params->{'status'},
1310                                 $params->{'message_id'} );
1311     return $result;
1312 }
1313
1314
1315 1;
1316 __END__