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         $mail{'Bcc'} = $userenv->{emailaddress}
 551           if C4::Context->preference("ClaimsBccCopy");
 552
 553         unless ( sendmail(%mail) ) {
 554             carp $Mail::Sendmail::error;
 555             return { error => $Mail::Sendmail::error };
 556         }
 557
 558         logaction(
 559             "ACQUISITION",
 560             $type eq 'claimissues' ? "CLAIM ISSUE" : "ACQUISITION CLAIM",
 561             undef,
 562             "To="
 563                 . join( ',', @email )
 564                 . " Title="
 565                 . $letter->{title}
 566                 . " Content="
 567                 . $letter->{content}
 568         ) if C4::Context->preference("LetterLog");
 569     }
 570    # send an "account details" notice to a newly created user
 571     elsif ( $type eq 'members' ) {
 572         my $branchdetails = GetBranchDetail($externalid->{'branchcode'});
 573         my $letter = GetPreparedLetter (
 574             module => 'members',
 575             letter_code => $letter_code,
 576             branchcode => $externalid->{'branchcode'},
 577             tables => {
 578                 'branches'    => $branchdetails,
 579                 'borrowers' => $externalid->{'borrowernumber'},
 580             },
 581             substitute => { 'borrowers.password' => $externalid->{'password'} },
 582             want_librarian => 1,
 583         ) or return;
 584         return { error => "no_email" } unless $externalid->{'emailaddr'};
 585         my $email = Koha::Email->new();
 586         my %mail  = $email->create_message_headers(
 587             {
 588                 to      => $externalid->{'emailaddr'},
 589                 from    => $branchdetails->{'branchemail'},
 590                 replyto => $branchdetails->{'branchreplyto'},
 591                 sender  => $branchdetails->{'branchreturnpath'},
 592                 subject => Encode::encode( "UTF-8", "" . $letter->{'title'} ),
 593                 message => $letter->{'is_html'}
 594                             ? _wrap_html( Encode::encode( "UTF-8", $letter->{'content'} ),
 595                                           Encode::encode( "UTF-8", "" . $letter->{'title'}  ) )
 596                             : Encode::encode( "UTF-8", "" . $letter->{'content'} ),
 597                 contenttype => $letter->{'is_html'}
 598                                 ? 'text/html; charset="utf-8"'
 599                                 : 'text/plain; charset="utf-8"',
 600             }
 601         );
 602         sendmail(%mail) or carp $Mail::Sendmail::error;
 603     }
 604 }
 605
 606 =head2 GetPreparedLetter( %params )
 607
 608     %params hash:
 609       module => letter module, mandatory
 610       letter_code => letter code, mandatory
 611       branchcode => for letter selection, if missing default system letter taken
 612       tables => a hashref with table names as keys. Values are either:
 613         - a scalar - primary key value
 614         - an arrayref - primary key values
 615         - a hashref - full record
 616       substitute => custom substitution key/value pairs
 617       repeat => records to be substituted on consecutive lines:
 618         - an arrayref - tries to guess what needs substituting by
 619           taking remaining << >> tokensr; not recommended
 620         - a hashref token => @tables - replaces <token> << >> << >> </token>
 621           subtemplate for each @tables row; table is a hashref as above
 622       want_librarian => boolean,  if set to true triggers librarian details
 623         substitution from the userenv
 624     Return value:
 625       letter fields hashref (title & content useful)
 626
 627 =cut
 628
 629 sub GetPreparedLetter {
 630     my %params = @_;
 631
 632     my $module      = $params{module} or croak "No module";
 633     my $letter_code = $params{letter_code} or croak "No letter_code";
 634     my $branchcode  = $params{branchcode} || '';
 635     my $mtt         = $params{message_transport_type} || 'email';
 636
 637     my $letter = getletter( $module, $letter_code, $branchcode, $mtt )
 638         or warn( "No $module $letter_code letter transported by " . $mtt ),
 639             return;
 640
 641     my $tables = $params{tables};
 642     my $substitute = $params{substitute};
 643     my $repeat = $params{repeat};
 644     $tables || $substitute || $repeat
 645       or carp( "ERROR: nothing to substitute - both 'tables' and 'substitute' are empty" ),
 646          return;
 647     my $want_librarian = $params{want_librarian};
 648
 649     if ($substitute) {
 650         while ( my ($token, $val) = each %$substitute ) {
 651             if ( $token eq 'items.content' ) {
 652                 $val =~ s|\n|<br/>|g if $letter->{is_html};
 653             }
 654
 655             $letter->{title} =~ s/<<$token>>/$val/g;
 656             $letter->{content} =~ s/<<$token>>/$val/g;
 657        }
 658     }
 659
 660     my $OPACBaseURL = C4::Context->preference('OPACBaseURL');
 661     $letter->{content} =~ s/<<OPACBaseURL>>/$OPACBaseURL/go;
 662
 663     if ($want_librarian) {
 664         # parsing librarian name
 665         my $userenv = C4::Context->userenv;
 666         $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/go;
 667         $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/go;
 668         $letter->{content} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/go;
 669     }
 670
 671     my ($repeat_no_enclosing_tags, $repeat_enclosing_tags);
 672
 673     if ($repeat) {
 674         if (ref ($repeat) eq 'ARRAY' ) {
 675             $repeat_no_enclosing_tags = $repeat;
 676         } else {
 677             $repeat_enclosing_tags = $repeat;
 678         }
 679     }
 680
 681     if ($repeat_enclosing_tags) {
 682         while ( my ($tag, $tag_tables) = each %$repeat_enclosing_tags ) {
 683             if ( $letter->{content} =~ m!<$tag>(.*)</$tag>!s ) {
 684                 my $subcontent = $1;
 685                 my @lines = map {
 686                     my %subletter = ( title => '', content => $subcontent );
 687                     _substitute_tables( \%subletter, $_ );
 688                     $subletter{content};
 689                 } @$tag_tables;
 690                 $letter->{content} =~ s!<$tag>.*</$tag>!join( "\n", @lines )!se;
 691             }
 692         }
 693     }
 694
 695     if ($tables) {
 696         _substitute_tables( $letter, $tables );
 697     }
 698
 699     if ($repeat_no_enclosing_tags) {
 700         if ( $letter->{content} =~ m/[^\n]*<<.*>>[^\n]*/so ) {
 701             my $line = $&;
 702             my $i = 1;
 703             my @lines = map {
 704                 my $c = $line;
 705                 $c =~ s/<<count>>/$i/go;
 706                 foreach my $field ( keys %{$_} ) {
 707                     $c =~ s/(<<[^\.]+.$field>>)/$_->{$field}/;
 708                 }
 709                 $i++;
 710                 $c;
 711             } @$repeat_no_enclosing_tags;
 712
 713             my $replaceby = join( "\n", @lines );
 714             $letter->{content} =~ s/\Q$line\E/$replaceby/s;
 715         }
 716     }
 717
 718     $letter->{content} =~ s/<<\S*>>//go; #remove any stragglers
 719 #   $letter->{content} =~ s/<<[^>]*>>//go;
 720
 721     return $letter;
 722 }
 723
 724 sub _substitute_tables {
 725     my ( $letter, $tables ) = @_;
 726     while ( my ($table, $param) = each %$tables ) {
 727         next unless $param;
 728
 729         my $ref = ref $param;
 730
 731         my $values;
 732         if ($ref && $ref eq 'HASH') {
 733             $values = $param;
 734         }
 735         else {
 736             my $sth = _parseletter_sth($table);
 737             unless ($sth) {
 738                 warn "_parseletter_sth('$table') failed to return a valid sth.  No substitution will be done for that table.";
 739                 return;
 740             }
 741             $sth->execute( $ref ? @$param : $param );
 742
 743             $values = $sth->fetchrow_hashref;
 744             $sth->finish();
 745         }
 746
 747         _parseletter ( $letter, $table, $values );
 748     }
 749 }
 750
 751 sub _parseletter_sth {
 752     my $table = shift;
 753     my $sth;
 754     unless ($table) {
 755         carp "ERROR: _parseletter_sth() called without argument (table)";
 756         return;
 757     }
 758     # NOTE: we used to check whether we had a statement handle cached in
 759     #       a %handles module-level variable. This was a dumb move and
 760     #       broke things for the rest of us. prepare_cached is a better
 761     #       way to cache statement handles anyway.
 762     my $query =
 763     ($table eq 'biblio'       ) ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 764     ($table eq 'biblioitems'  ) ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 765     ($table eq 'items'        ) ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 766     ($table eq 'issues'       ) ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 767     ($table eq 'old_issues'   ) ? "SELECT * FROM $table WHERE     itemnumber = ? ORDER BY timestamp DESC LIMIT 1"  :
 768     ($table eq 'reserves'     ) ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?"             :
 769     ($table eq 'borrowers'    ) ? "SELECT * FROM $table WHERE borrowernumber = ?"                                  :
 770     ($table eq 'branches'     ) ? "SELECT * FROM $table WHERE     branchcode = ?"                                  :
 771     ($table eq 'suggestions'  ) ? "SELECT * FROM $table WHERE   suggestionid = ?"                                  :
 772     ($table eq 'aqbooksellers') ? "SELECT * FROM $table WHERE             id = ?"                                  :
 773     ($table eq 'aqorders'     ) ? "SELECT * FROM $table WHERE    ordernumber = ?"                                  :
 774     ($table eq 'opac_news'    ) ? "SELECT * FROM $table WHERE          idnew = ?"                                  :
 775     ($table eq 'borrower_modifications') ? "SELECT * FROM $table WHERE verification_token = ?" :
 776     ($table eq 'subscription') ? "SELECT * FROM $table WHERE subscriptionid = ?" :
 777     ($table eq 'serial') ? "SELECT * FROM $table WHERE serialid = ?" :
 778     undef ;
 779     unless ($query) {
 780         warn "ERROR: No _parseletter_sth query for table '$table'";
 781         return;     # nothing to get
 782     }
 783     unless ($sth = C4::Context->dbh->prepare_cached($query)) {
 784         warn "ERROR: Failed to prepare query: '$query'";
 785         return;
 786     }
 787     return $sth;    # now cache is populated for that $table
 788 }
 789
 790 =head2 _parseletter($letter, $table, $values)
 791
 792     parameters :
 793     - $letter : a hash to letter fields (title & content useful)
 794     - $table : the Koha table to parse.
 795     - $values_in : table record hashref
 796     parse all fields from a table, and replace values in title & content with the appropriate value
 797     (not exported sub, used only internally)
 798
 799 =cut
 800
 801 sub _parseletter {
 802     my ( $letter, $table, $values_in ) = @_;
 803
 804     # Work on a local copy of $values_in (passed by reference) to avoid side effects
 805     # in callers ( by changing / formatting values )
 806     my $values = $values_in ? { %$values_in } : {};
 807
 808     if ( $table eq 'borrowers' && $values->{'dateexpiry'} ){
 809         $values->{'dateexpiry'} = format_sqldatetime( $values->{'dateexpiry'} );
 810     }
 811
 812     if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
 813         my @waitingdate = split /-/, $values->{'waitingdate'};
 814
 815         $values->{'expirationdate'} = '';
 816         if ( C4::Context->preference('ReservesMaxPickUpDelay') ) {
 817             my $dt = dt_from_string();
 818             $dt->add( days => C4::Context->preference('ReservesMaxPickUpDelay') );
 819             $values->{'expirationdate'} = output_pref( { dt => $dt, dateonly => 1 } );
 820         }
 821
 822         $values->{'waitingdate'} = output_pref({ dt => dt_from_string( $values->{'waitingdate'} ), dateonly => 1 });
 823
 824     }
 825
 826     if ($letter->{content} && $letter->{content} =~ /<<today>>/) {
 827         my $todaysdate = output_pref( DateTime->now() );
 828         $letter->{content} =~ s/<<today>>/$todaysdate/go;
 829     }
 830
 831     while ( my ($field, $val) = each %$values ) {
 832         $val =~ s/\p{P}$// if $val && $table=~/biblio/;
 833             #BZ 9886: Assuming that we want to eliminate ISBD punctuation here
 834             #Therefore adding the test on biblio. This includes biblioitems,
 835             #but excludes items. Removed unneeded global and lookahead.
 836
 837         $val = GetAuthorisedValueByCode ('ROADTYPE', $val, 0) if $table=~/^borrowers$/ && $field=~/^streettype$/;
 838
 839         # Dates replacement
 840         my $replacedby   = defined ($val) ? $val : '';
 841         if (    $replacedby
 842             and not $replacedby =~ m|0000-00-00|
 843             and not $replacedby =~ m|9999-12-31|
 844             and $replacedby =~ m|^\d{4}-\d{2}-\d{2}( \d{2}:\d{2}:\d{2})?$| )
 845         {
 846             # If the value is XXXX-YY-ZZ[ AA:BB:CC] we assume it is a date
 847             my $dateonly = defined $1 ? 0 : 1; #$1 refers to the capture group wrapped in parentheses. In this case, that's the hours, minutes, seconds.
 848             my $re_dateonly_filter = qr{ $field( \s* \| \s* dateonly\s*)?>> }xms;
 849
 850             for my $letter_field ( qw( title content ) ) {
 851                 my $filter_string_used = q{};
 852                 if ( $letter->{ $letter_field } =~ $re_dateonly_filter ) {
 853                     # We overwrite $dateonly if the filter exists and we have a time in the datetime
 854                     $filter_string_used = $1 || q{};
 855                     $dateonly = $1 unless $dateonly;
 856                 }
 857                 eval {
 858                     $replacedby = output_pref({ dt => dt_from_string( $replacedby ), dateonly => $dateonly });
 859                 };
 860
 861                 if ( $letter->{ $letter_field } ) {
 862                     $letter->{ $letter_field } =~ s/\Q<<$table.$field$filter_string_used>>\E/$replacedby/g;
 863                     $letter->{ $letter_field } =~ s/\Q<<$field$filter_string_used>>\E/$replacedby/g;
 864                 }
 865             }
 866         }
 867         # Other fields replacement
 868         else {
 869             for my $letter_field ( qw( title content ) ) {
 870                 if ( $letter->{ $letter_field } ) {
 871                     $letter->{ $letter_field }   =~ s/<<$table.$field>>/$replacedby/g;
 872                     $letter->{ $letter_field }   =~ s/<<$field>>/$replacedby/g;
 873                 }
 874             }
 875         }
 876     }
 877
 878     if ($table eq 'borrowers' && $letter->{content}) {
 879         if ( my $attributes = GetBorrowerAttributes($values->{borrowernumber}) ) {
 880             my %attr;
 881             foreach (@$attributes) {
 882                 my $code = $_->{code};
 883                 my $val  = $_->{value_description} || $_->{value};
 884                 $val =~ s/\p{P}(?=$)//g if $val;
 885                 next unless $val gt '';
 886                 $attr{$code} ||= [];
 887                 push @{ $attr{$code} }, $val;
 888             }
 889             while ( my ($code, $val_ar) = each %attr ) {
 890                 my $replacefield = "<<borrower-attribute:$code>>";
 891                 my $replacedby   = join ',', @$val_ar;
 892                 $letter->{content} =~ s/$replacefield/$replacedby/g;
 893             }
 894         }
 895     }
 896     return $letter;
 897 }
 898
 899 =head2 EnqueueLetter
 900
 901   my $success = EnqueueLetter( { letter => $letter,
 902         borrowernumber => '12', message_transport_type => 'email' } )
 903
 904 places a letter in the message_queue database table, which will
 905 eventually get processed (sent) by the process_message_queue.pl
 906 cronjob when it calls SendQueuedMessages.
 907
 908 return message_id on success
 909
 910 =cut
 911
 912 sub EnqueueLetter {
 913     my $params = shift or return;
 914
 915     return unless exists $params->{'letter'};
 916 #   return unless exists $params->{'borrowernumber'};
 917     return unless exists $params->{'message_transport_type'};
 918
 919     my $content = $params->{letter}->{content};
 920     $content =~ s/\s+//g if(defined $content);
 921     if ( not defined $content or $content eq '' ) {
 922         warn "Trying to add an empty message to the message queue" if $debug;
 923         return;
 924     }
 925
 926     # If we have any attachments we should encode then into the body.
 927     if ( $params->{'attachments'} ) {
 928         $params->{'letter'} = _add_attachments(
 929             {   letter      => $params->{'letter'},
 930                 attachments => $params->{'attachments'},
 931                 message     => MIME::Lite->new( Type => 'multipart/mixed' ),
 932             }
 933         );
 934     }
 935
 936     my $dbh       = C4::Context->dbh();
 937     my $statement = << 'ENDSQL';
 938 INSERT INTO message_queue
 939 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type )
 940 VALUES
 941 ( ?,              ?,       ?,       ?,        ?,           ?,                      ?,      NOW(),       ?,          ?,            ? )
 942 ENDSQL
 943
 944     my $sth    = $dbh->prepare($statement);
 945     my $result = $sth->execute(
 946         $params->{'borrowernumber'},              # borrowernumber
 947         $params->{'letter'}->{'title'},           # subject
 948         $params->{'letter'}->{'content'},         # content
 949         $params->{'letter'}->{'metadata'} || '',  # metadata
 950         $params->{'letter'}->{'code'}     || '',  # letter_code
 951         $params->{'message_transport_type'},      # message_transport_type
 952         'pending',                                # status
 953         $params->{'to_address'},                  # to_address
 954         $params->{'from_address'},                # from_address
 955         $params->{'letter'}->{'content-type'},    # content_type
 956     );
 957     return $dbh->last_insert_id(undef,undef,'message_queue', undef);
 958 }
 959
 960 =head2 SendQueuedMessages ([$hashref])
 961
 962   my $sent = SendQueuedMessages( { verbose => 1 } );
 963
 964 sends all of the 'pending' items in the message queue.
 965
 966 returns number of messages sent.
 967
 968 =cut
 969
 970 sub SendQueuedMessages {
 971     my $params = shift;
 972
 973     my $unsent_messages = _get_unsent_messages();
 974     MESSAGE: foreach my $message ( @$unsent_messages ) {
 975         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
 976         warn sprintf( 'sending %s message to patron: %s',
 977                       $message->{'message_transport_type'},
 978                       $message->{'borrowernumber'} || 'Admin' )
 979           if $params->{'verbose'} or $debug;
 980         # This is just begging for subclassing
 981         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
 982         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
 983             _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
 984         }
 985         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
 986             _send_message_by_sms( $message );
 987         }
 988     }
 989     return scalar( @$unsent_messages );
 990 }
 991
 992 =head2 GetRSSMessages
 993
 994   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
 995
 996 returns a listref of all queued RSS messages for a particular person.
 997
 998 =cut
 999
1000 sub GetRSSMessages {
1001     my $params = shift;
1002
1003     return unless $params;
1004     return unless ref $params;
1005     return unless $params->{'borrowernumber'};
1006
1007     return _get_unsent_messages( { message_transport_type => 'rss',
1008                                    limit                  => $params->{'limit'},
1009                                    borrowernumber         => $params->{'borrowernumber'}, } );
1010 }
1011
1012 =head2 GetPrintMessages
1013
1014   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
1015
1016 Returns a arrayref of all queued print messages (optionally, for a particular
1017 person).
1018
1019 =cut
1020
1021 sub GetPrintMessages {
1022     my $params = shift || {};
1023
1024     return _get_unsent_messages( { message_transport_type => 'print',
1025                                    borrowernumber         => $params->{'borrowernumber'},
1026                                  } );
1027 }
1028
1029 =head2 GetQueuedMessages ([$hashref])
1030
1031   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
1032
1033 fetches messages out of the message queue.
1034
1035 returns:
1036 list of hashes, each has represents a message in the message queue.
1037
1038 =cut
1039
1040 sub GetQueuedMessages {
1041     my $params = shift;
1042
1043     my $dbh = C4::Context->dbh();
1044     my $statement = << 'ENDSQL';
1045 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued
1046 FROM message_queue
1047 ENDSQL
1048
1049     my @query_params;
1050     my @whereclauses;
1051     if ( exists $params->{'borrowernumber'} ) {
1052         push @whereclauses, ' borrowernumber = ? ';
1053         push @query_params, $params->{'borrowernumber'};
1054     }
1055
1056     if ( @whereclauses ) {
1057         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
1058     }
1059
1060     if ( defined $params->{'limit'} ) {
1061         $statement .= ' LIMIT ? ';
1062         push @query_params, $params->{'limit'};
1063     }
1064
1065     my $sth = $dbh->prepare( $statement );
1066     my $result = $sth->execute( @query_params );
1067     return $sth->fetchall_arrayref({});
1068 }
1069
1070 =head2 GetMessageTransportTypes
1071
1072   my @mtt = GetMessageTransportTypes();
1073
1074   returns an arrayref of transport types
1075
1076 =cut
1077
1078 sub GetMessageTransportTypes {
1079     my $dbh = C4::Context->dbh();
1080     my $mtts = $dbh->selectcol_arrayref("
1081         SELECT message_transport_type
1082         FROM message_transport_types
1083         ORDER BY message_transport_type
1084     ");
1085     return $mtts;
1086 }
1087
1088 =head2 _add_attachements
1089
1090 named parameters:
1091 letter - the standard letter hashref
1092 attachments - listref of attachments. each attachment is a hashref of:
1093   type - the mime type, like 'text/plain'
1094   content - the actual attachment
1095   filename - the name of the attachment.
1096 message - a MIME::Lite object to attach these to.
1097
1098 returns your letter object, with the content updated.
1099
1100 =cut
1101
1102 sub _add_attachments {
1103     my $params = shift;
1104
1105     my $letter = $params->{'letter'};
1106     my $attachments = $params->{'attachments'};
1107     return $letter unless @$attachments;
1108     my $message = $params->{'message'};
1109
1110     # First, we have to put the body in as the first attachment
1111     $message->attach(
1112         Type => $letter->{'content-type'} || 'TEXT',
1113         Data => $letter->{'is_html'}
1114             ? _wrap_html($letter->{'content'}, $letter->{'title'})
1115             : $letter->{'content'},
1116     );
1117
1118     foreach my $attachment ( @$attachments ) {
1119         $message->attach(
1120             Type     => $attachment->{'type'},
1121             Data     => $attachment->{'content'},
1122             Filename => $attachment->{'filename'},
1123         );
1124     }
1125     # we're forcing list context here to get the header, not the count back from grep.
1126     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
1127     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
1128     $letter->{'content'} = $message->body_as_string;
1129
1130     return $letter;
1131
1132 }
1133
1134 sub _get_unsent_messages {
1135     my $params = shift;
1136
1137     my $dbh = C4::Context->dbh();
1138     my $statement = << 'ENDSQL';
1139 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
1140   FROM message_queue mq
1141   LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
1142  WHERE status = ?
1143 ENDSQL
1144
1145     my @query_params = ('pending');
1146     if ( ref $params ) {
1147         if ( $params->{'message_transport_type'} ) {
1148             $statement .= ' AND message_transport_type = ? ';
1149             push @query_params, $params->{'message_transport_type'};
1150         }
1151         if ( $params->{'borrowernumber'} ) {
1152             $statement .= ' AND borrowernumber = ? ';
1153             push @query_params, $params->{'borrowernumber'};
1154         }
1155         if ( $params->{'limit'} ) {
1156             $statement .= ' limit ? ';
1157             push @query_params, $params->{'limit'};
1158         }
1159     }
1160
1161     $debug and warn "_get_unsent_messages SQL: $statement";
1162     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
1163     my $sth = $dbh->prepare( $statement );
1164     my $result = $sth->execute( @query_params );
1165     return $sth->fetchall_arrayref({});
1166 }
1167
1168 sub _send_message_by_email {
1169     my $message = shift or return;
1170     my ($username, $password, $method) = @_;
1171
1172     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
1173     my $to_address = $message->{'to_address'};
1174     unless ($to_address) {
1175         unless ($member) {
1176             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
1177             _set_message_status( { message_id => $message->{'message_id'},
1178                                    status     => 'failed' } );
1179             return;
1180         }
1181         $to_address = C4::Members::GetNoticeEmailAddress( $message->{'borrowernumber'} );
1182         unless ($to_address) {
1183             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
1184             # warning too verbose for this more common case?
1185             _set_message_status( { message_id => $message->{'message_id'},
1186                                    status     => 'failed' } );
1187             return;
1188         }
1189     }
1190
1191     my $utf8   = decode('MIME-Header', $message->{'subject'} );
1192     $message->{subject}= encode('MIME-Header', $utf8);
1193     my $subject = encode('UTF-8', $message->{'subject'});
1194     my $content = encode('UTF-8', $message->{'content'});
1195     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
1196     my $is_html = $content_type =~ m/html/io;
1197     my $branch_email = undef;
1198     my $branch_replyto = undef;
1199     my $branch_returnpath = undef;
1200     if ($member){
1201         my $branchdetail = GetBranchDetail( $member->{'branchcode'} );
1202         $branch_email = $branchdetail->{'branchemail'};
1203         $branch_replyto = $branchdetail->{'branchreplyto'};
1204         $branch_returnpath = $branchdetail->{'branchreturnpath'};
1205     }
1206     my $email = Koha::Email->new();
1207     my %sendmail_params = $email->create_message_headers(
1208         {
1209             to      => $to_address,
1210             from    => $message->{'from_address'} || $branch_email,
1211             replyto => $branch_replyto,
1212             sender  => $branch_returnpath,
1213             subject => $subject,
1214             message => $is_html ? _wrap_html( $content, $subject ) : $content,
1215             contenttype => $content_type
1216         }
1217     );
1218
1219     $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
1220     if ( my $bcc = C4::Context->preference('OverdueNoticeBcc') ) {
1221        $sendmail_params{ Bcc } = $bcc;
1222     }
1223
1224     _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
1225     if ( sendmail( %sendmail_params ) ) {
1226         _set_message_status( { message_id => $message->{'message_id'},
1227                 status     => 'sent' } );
1228         return 1;
1229     } else {
1230         _set_message_status( { message_id => $message->{'message_id'},
1231                 status     => 'failed' } );
1232         carp $Mail::Sendmail::error;
1233         return;
1234     }
1235 }
1236
1237 sub _wrap_html {
1238     my ($content, $title) = @_;
1239
1240     my $css = C4::Context->preference("NoticeCSS") || '';
1241     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
1242     return <<EOS;
1243 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1244     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1245 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1246 <head>
1247 <title>$title</title>
1248 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1249 $css
1250 </head>
1251 <body>
1252 $content
1253 </body>
1254 </html>
1255 EOS
1256 }
1257
1258 sub _is_duplicate {
1259     my ( $message ) = @_;
1260     my $dbh = C4::Context->dbh;
1261     my $count = $dbh->selectrow_array(q|
1262         SELECT COUNT(*)
1263         FROM message_queue
1264         WHERE message_transport_type = ?
1265         AND borrowernumber = ?
1266         AND letter_code = ?
1267         AND CAST(time_queued AS date) = CAST(NOW() AS date)
1268         AND status="sent"
1269         AND content = ?
1270     |, {}, $message->{message_transport_type}, $message->{borrowernumber}, $message->{letter_code}, $message->{content} );
1271     return $count;
1272 }
1273
1274 sub _send_message_by_sms {
1275     my $message = shift or return;
1276     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
1277
1278     unless ( $member->{smsalertnumber} ) {
1279         _set_message_status( { message_id => $message->{'message_id'},
1280                                status     => 'failed' } );
1281         return;
1282     }
1283
1284     if ( _is_duplicate( $message ) ) {
1285         _set_message_status( { message_id => $message->{'message_id'},
1286                                status     => 'failed' } );
1287         return;
1288     }
1289
1290     my $success = C4::SMS->send_sms( { destination => $member->{'smsalertnumber'},
1291                                        message     => $message->{'content'},
1292                                      } );
1293     _set_message_status( { message_id => $message->{'message_id'},
1294                            status     => ($success ? 'sent' : 'failed') } );
1295     return $success;
1296 }
1297
1298 sub _update_message_to_address {
1299     my ($id, $to)= @_;
1300     my $dbh = C4::Context->dbh();
1301     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1302 }
1303
1304 sub _set_message_status {
1305     my $params = shift or return;
1306
1307     foreach my $required_parameter ( qw( message_id status ) ) {
1308         return unless exists $params->{ $required_parameter };
1309     }
1310
1311     my $dbh = C4::Context->dbh();
1312     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1313     my $sth = $dbh->prepare( $statement );
1314     my $result = $sth->execute( $params->{'status'},
1315                                 $params->{'message_id'} );
1316     return $result;
1317 }
1318
1319
1320 1;
1321 __END__