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