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         if ( $replacedby and $replacedby =~ m|^\d{4}-\d{2}-\d{2}( \d{2}:\d{2}:\d{2})?$| ) {
 624             # If the value is XXXX-YY-ZZ[ AA:BB:CC] we assume it is a date
 625             my $dateonly = defined $1 ? 0 : 1; #$1 refers to the capture group wrapped in parentheses. In this case, that's the hours, minutes, seconds.
 626             eval {
 627                 $replacedby = output_pref({ dt => dt_from_string( $replacedby ), dateonly => $dateonly });
 628             };
 629             warn "$replacedby seems to be a date but an error occurs on generating it ($@)" if $@;
 630         }
 631         ($letter->{title}  ) and do {
 632             $letter->{title}   =~ s/$replacetablefield/$replacedby/g;
 633             $letter->{title}   =~ s/$replacefield/$replacedby/g;
 634         };
 635         ($letter->{content}) and do {
 636             $letter->{content} =~ s/$replacetablefield/$replacedby/g;
 637             $letter->{content} =~ s/$replacefield/$replacedby/g;
 638         };
 639     }
 640
 641     if ($table eq 'borrowers' && $letter->{content}) {
 642         if ( my $attributes = GetBorrowerAttributes($values->{borrowernumber}) ) {
 643             my %attr;
 644             foreach (@$attributes) {
 645                 my $code = $_->{code};
 646                 my $val  = $_->{value_description} || $_->{value};
 647                 $val =~ s/\p{P}(?=$)//g if $val;
 648                 next unless $val gt '';
 649                 $attr{$code} ||= [];
 650                 push @{ $attr{$code} }, $val;
 651             }
 652             while ( my ($code, $val_ar) = each %attr ) {
 653                 my $replacefield = "<<borrower-attribute:$code>>";
 654                 my $replacedby   = join ',', @$val_ar;
 655                 $letter->{content} =~ s/$replacefield/$replacedby/g;
 656             }
 657         }
 658     }
 659     return $letter;
 660 }
 661
 662 =head2 EnqueueLetter
 663
 664   my $success = EnqueueLetter( { letter => $letter,
 665         borrowernumber => '12', message_transport_type => 'email' } )
 666
 667 places a letter in the message_queue database table, which will
 668 eventually get processed (sent) by the process_message_queue.pl
 669 cronjob when it calls SendQueuedMessages.
 670
 671 return message_id on success
 672
 673 =cut
 674
 675 sub EnqueueLetter {
 676     my $params = shift or return;
 677
 678     return unless exists $params->{'letter'};
 679 #   return unless exists $params->{'borrowernumber'};
 680     return unless exists $params->{'message_transport_type'};
 681
 682     my $content = $params->{letter}->{content};
 683     $content =~ s/\s+//g if(defined $content);
 684     if ( not defined $content or $content eq '' ) {
 685         warn "Trying to add an empty message to the message queue" if $debug;
 686         return;
 687     }
 688
 689     # If we have any attachments we should encode then into the body.
 690     if ( $params->{'attachments'} ) {
 691         $params->{'letter'} = _add_attachments(
 692             {   letter      => $params->{'letter'},
 693                 attachments => $params->{'attachments'},
 694                 message     => MIME::Lite->new( Type => 'multipart/mixed' ),
 695             }
 696         );
 697     }
 698
 699     my $dbh       = C4::Context->dbh();
 700     my $statement = << 'ENDSQL';
 701 INSERT INTO message_queue
 702 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type )
 703 VALUES
 704 ( ?,              ?,       ?,       ?,        ?,           ?,                      ?,      NOW(),       ?,          ?,            ? )
 705 ENDSQL
 706
 707     my $sth    = $dbh->prepare($statement);
 708     my $result = $sth->execute(
 709         $params->{'borrowernumber'},              # borrowernumber
 710         $params->{'letter'}->{'title'},           # subject
 711         $params->{'letter'}->{'content'},         # content
 712         $params->{'letter'}->{'metadata'} || '',  # metadata
 713         $params->{'letter'}->{'code'}     || '',  # letter_code
 714         $params->{'message_transport_type'},      # message_transport_type
 715         'pending',                                # status
 716         $params->{'to_address'},                  # to_address
 717         $params->{'from_address'},                # from_address
 718         $params->{'letter'}->{'content-type'},    # content_type
 719     );
 720     return $dbh->last_insert_id(undef,undef,'message_queue', undef);
 721 }
 722
 723 =head2 SendQueuedMessages ([$hashref])
 724
 725   my $sent = SendQueuedMessages( { verbose => 1 } );
 726
 727 sends all of the 'pending' items in the message queue.
 728
 729 returns number of messages sent.
 730
 731 =cut
 732
 733 sub SendQueuedMessages {
 734     my $params = shift;
 735
 736     my $unsent_messages = _get_unsent_messages();
 737     MESSAGE: foreach my $message ( @$unsent_messages ) {
 738         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
 739         warn sprintf( 'sending %s message to patron: %s',
 740                       $message->{'message_transport_type'},
 741                       $message->{'borrowernumber'} || 'Admin' )
 742           if $params->{'verbose'} or $debug;
 743         # This is just begging for subclassing
 744         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
 745         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
 746             _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
 747         }
 748         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
 749             _send_message_by_sms( $message );
 750         }
 751     }
 752     return scalar( @$unsent_messages );
 753 }
 754
 755 =head2 GetRSSMessages
 756
 757   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
 758
 759 returns a listref of all queued RSS messages for a particular person.
 760
 761 =cut
 762
 763 sub GetRSSMessages {
 764     my $params = shift;
 765
 766     return unless $params;
 767     return unless ref $params;
 768     return unless $params->{'borrowernumber'};
 769
 770     return _get_unsent_messages( { message_transport_type => 'rss',
 771                                    limit                  => $params->{'limit'},
 772                                    borrowernumber         => $params->{'borrowernumber'}, } );
 773 }
 774
 775 =head2 GetPrintMessages
 776
 777   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
 778
 779 Returns a arrayref of all queued print messages (optionally, for a particular
 780 person).
 781
 782 =cut
 783
 784 sub GetPrintMessages {
 785     my $params = shift || {};
 786
 787     return _get_unsent_messages( { message_transport_type => 'print',
 788                                    borrowernumber         => $params->{'borrowernumber'},
 789                                  } );
 790 }
 791
 792 =head2 GetQueuedMessages ([$hashref])
 793
 794   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
 795
 796 fetches messages out of the message queue.
 797
 798 returns:
 799 list of hashes, each has represents a message in the message queue.
 800
 801 =cut
 802
 803 sub GetQueuedMessages {
 804     my $params = shift;
 805
 806     my $dbh = C4::Context->dbh();
 807     my $statement = << 'ENDSQL';
 808 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued
 809 FROM message_queue
 810 ENDSQL
 811
 812     my @query_params;
 813     my @whereclauses;
 814     if ( exists $params->{'borrowernumber'} ) {
 815         push @whereclauses, ' borrowernumber = ? ';
 816         push @query_params, $params->{'borrowernumber'};
 817     }
 818
 819     if ( @whereclauses ) {
 820         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
 821     }
 822
 823     if ( defined $params->{'limit'} ) {
 824         $statement .= ' LIMIT ? ';
 825         push @query_params, $params->{'limit'};
 826     }
 827
 828     my $sth = $dbh->prepare( $statement );
 829     my $result = $sth->execute( @query_params );
 830     return $sth->fetchall_arrayref({});
 831 }
 832
 833 =head2 GetMessageTransportTypes
 834
 835   my @mtt = GetMessageTransportTypes();
 836
 837   returns an arrayref of transport types
 838
 839 =cut
 840
 841 sub GetMessageTransportTypes {
 842     my $dbh = C4::Context->dbh();
 843     my $mtts = $dbh->selectcol_arrayref("
 844         SELECT message_transport_type
 845         FROM message_transport_types
 846         ORDER BY message_transport_type
 847     ");
 848     return $mtts;
 849 }
 850
 851 =head2 _add_attachements
 852
 853 named parameters:
 854 letter - the standard letter hashref
 855 attachments - listref of attachments. each attachment is a hashref of:
 856   type - the mime type, like 'text/plain'
 857   content - the actual attachment
 858   filename - the name of the attachment.
 859 message - a MIME::Lite object to attach these to.
 860
 861 returns your letter object, with the content updated.
 862
 863 =cut
 864
 865 sub _add_attachments {
 866     my $params = shift;
 867
 868     my $letter = $params->{'letter'};
 869     my $attachments = $params->{'attachments'};
 870     return $letter unless @$attachments;
 871     my $message = $params->{'message'};
 872
 873     # First, we have to put the body in as the first attachment
 874     $message->attach(
 875         Type => $letter->{'content-type'} || 'TEXT',
 876         Data => $letter->{'is_html'}
 877             ? _wrap_html($letter->{'content'}, $letter->{'title'})
 878             : $letter->{'content'},
 879     );
 880
 881     foreach my $attachment ( @$attachments ) {
 882         $message->attach(
 883             Type     => $attachment->{'type'},
 884             Data     => $attachment->{'content'},
 885             Filename => $attachment->{'filename'},
 886         );
 887     }
 888     # we're forcing list context here to get the header, not the count back from grep.
 889     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
 890     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
 891     $letter->{'content'} = $message->body_as_string;
 892
 893     return $letter;
 894
 895 }
 896
 897 sub _get_unsent_messages {
 898     my $params = shift;
 899
 900     my $dbh = C4::Context->dbh();
 901     my $statement = << 'ENDSQL';
 902 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
 903   FROM message_queue mq
 904   LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
 905  WHERE status = ?
 906 ENDSQL
 907
 908     my @query_params = ('pending');
 909     if ( ref $params ) {
 910         if ( $params->{'message_transport_type'} ) {
 911             $statement .= ' AND message_transport_type = ? ';
 912             push @query_params, $params->{'message_transport_type'};
 913         }
 914         if ( $params->{'borrowernumber'} ) {
 915             $statement .= ' AND borrowernumber = ? ';
 916             push @query_params, $params->{'borrowernumber'};
 917         }
 918         if ( $params->{'limit'} ) {
 919             $statement .= ' limit ? ';
 920             push @query_params, $params->{'limit'};
 921         }
 922     }
 923
 924     $debug and warn "_get_unsent_messages SQL: $statement";
 925     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
 926     my $sth = $dbh->prepare( $statement );
 927     my $result = $sth->execute( @query_params );
 928     return $sth->fetchall_arrayref({});
 929 }
 930
 931 sub _send_message_by_email {
 932     my $message = shift or return;
 933     my ($username, $password, $method) = @_;
 934
 935     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
 936     my $to_address = $message->{'to_address'};
 937     unless ($to_address) {
 938         unless ($member) {
 939             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
 940             _set_message_status( { message_id => $message->{'message_id'},
 941                                    status     => 'failed' } );
 942             return;
 943         }
 944         $to_address = C4::Members::GetNoticeEmailAddress( $message->{'borrowernumber'} );
 945         unless ($to_address) {
 946             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
 947             # warning too verbose for this more common case?
 948             _set_message_status( { message_id => $message->{'message_id'},
 949                                    status     => 'failed' } );
 950             return;
 951         }
 952     }
 953
 954     my $utf8   = decode('MIME-Header', $message->{'subject'} );
 955     $message->{subject}= encode('MIME-Header', $utf8);
 956     my $subject = encode('utf8', $message->{'subject'});
 957     my $content = encode('utf8', $message->{'content'});
 958     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
 959     my $is_html = $content_type =~ m/html/io;
 960
 961     my $branch_email = ( $member ) ? GetBranchDetail( $member->{'branchcode'} )->{'branchemail'} : undef;
 962
 963     my %sendmail_params = (
 964         To   => $to_address,
 965         From => $message->{'from_address'} || $branch_email || C4::Context->preference('KohaAdminEmailAddress'),
 966         Subject => $subject,
 967         charset => 'utf8',
 968         Message => $is_html ? _wrap_html($content, $subject) : $content,
 969         'content-type' => $content_type,
 970     );
 971     $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
 972     if ( my $bcc = C4::Context->preference('OverdueNoticeBcc') ) {
 973        $sendmail_params{ Bcc } = $bcc;
 974     }
 975
 976     _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
 977     if ( sendmail( %sendmail_params ) ) {
 978         _set_message_status( { message_id => $message->{'message_id'},
 979                 status     => 'sent' } );
 980         return 1;
 981     } else {
 982         _set_message_status( { message_id => $message->{'message_id'},
 983                 status     => 'failed' } );
 984         carp $Mail::Sendmail::error;
 985         return;
 986     }
 987 }
 988
 989 sub _wrap_html {
 990     my ($content, $title) = @_;
 991
 992     my $css = C4::Context->preference("NoticeCSS") || '';
 993     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
 994     return <<EOS;
 995 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
 996     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
 997 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
 998 <head>
 999 <title>$title</title>
1000 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1001 $css
1002 </head>
1003 <body>
1004 $content
1005 </body>
1006 </html>
1007 EOS
1008 }
1009
1010 sub _is_duplicate {
1011     my ( $message ) = @_;
1012     my $dbh = C4::Context->dbh;
1013     my $count = $dbh->selectrow_array(q|
1014         SELECT COUNT(*)
1015         FROM message_queue
1016         WHERE message_transport_type = ?
1017         AND borrowernumber = ?
1018         AND letter_code = ?
1019         AND CAST(time_queued AS date) = CAST(NOW() AS date)
1020         AND status="sent"
1021         AND content = ?
1022     |, {}, $message->{message_transport_type}, $message->{borrowernumber}, $message->{letter_code}, $message->{content} );
1023     return $count;
1024 }
1025
1026 sub _send_message_by_sms {
1027     my $message = shift or return;
1028     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
1029
1030     unless ( $member->{smsalertnumber} ) {
1031         _set_message_status( { message_id => $message->{'message_id'},
1032                                status     => 'failed' } );
1033         return;
1034     }
1035
1036     if ( _is_duplicate( $message ) ) {
1037         _set_message_status( { message_id => $message->{'message_id'},
1038                                status     => 'failed' } );
1039         return;
1040     }
1041
1042     my $success = C4::SMS->send_sms( { destination => $member->{'smsalertnumber'},
1043                                        message     => $message->{'content'},
1044                                      } );
1045     _set_message_status( { message_id => $message->{'message_id'},
1046                            status     => ($success ? 'sent' : 'failed') } );
1047     return $success;
1048 }
1049
1050 sub _update_message_to_address {
1051     my ($id, $to)= @_;
1052     my $dbh = C4::Context->dbh();
1053     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1054 }
1055
1056 sub _set_message_status {
1057     my $params = shift or return;
1058
1059     foreach my $required_parameter ( qw( message_id status ) ) {
1060         return unless exists $params->{ $required_parameter };
1061     }
1062
1063     my $dbh = C4::Context->dbh();
1064     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1065     my $sth = $dbh->prepare( $statement );
1066     my $result = $sth->execute( $params->{'status'},
1067                                 $params->{'message_id'} );
1068     return $result;
1069 }
1070
1071
1072 1;
1073 __END__