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