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