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