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