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