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.*
 310             FROM aqorders
 311             LEFT JOIN aqbasket ON aqbasket.basketno=aqorders.basketno
 312             LEFT JOIN biblio ON aqorders.biblionumber=biblio.biblionumber
 313             LEFT JOIN biblioitems ON aqorders.biblionumber=biblioitems.biblionumber
 314             WHERE aqorders.ordernumber IN (
 315             }
 316             : qq{
 317             SELECT serial.*,subscription.*, biblio.*, aqbooksellers.*,
 318             aqbooksellers.id AS booksellerid
 319             FROM serial
 320             LEFT JOIN subscription ON serial.subscriptionid=subscription.subscriptionid
 321             LEFT JOIN biblio ON serial.biblionumber=biblio.biblionumber
 322             LEFT JOIN aqbooksellers ON subscription.aqbooksellerid=aqbooksellers.id
 323             WHERE serial.serialid IN (
 324             };
 325
 326         if (!@$externalid){
 327             carp "No Order seleted";
 328             return { error => "no_order_seleted" };
 329         }
 330
 331         $strsth .= join( ",", @$externalid ) . ")";
 332         my $sthorders = $dbh->prepare($strsth);
 333         $sthorders->execute;
 334         my $dataorders = $sthorders->fetchall_arrayref( {} );
 335
 336         my $sthbookseller =
 337           $dbh->prepare("select * from aqbooksellers where id=?");
 338         $sthbookseller->execute( $dataorders->[0]->{booksellerid} );
 339         my $databookseller = $sthbookseller->fetchrow_hashref;
 340         my $addressee =  $type eq 'claimacquisition' ? 'acqprimary' : 'serialsprimary';
 341         my $sthcontact =
 342           $dbh->prepare("SELECT * FROM aqcontacts WHERE booksellerid=? AND $type=1 ORDER BY $addressee DESC");
 343         $sthcontact->execute( $dataorders->[0]->{booksellerid} );
 344         my $datacontact = $sthcontact->fetchrow_hashref;
 345
 346         my @email;
 347         my @cc;
 348         push @email, $databookseller->{bookselleremail} if $databookseller->{bookselleremail};
 349         push @email, $datacontact->{email}           if ( $datacontact && $datacontact->{email} );
 350         unless (@email) {
 351             warn "Bookseller $dataorders->[0]->{booksellerid} without emails";
 352             return { error => "no_email" };
 353         }
 354         my $addlcontact;
 355         while ($addlcontact = $sthcontact->fetchrow_hashref) {
 356             push @cc, $addlcontact->{email} if ( $addlcontact && $addlcontact->{email} );
 357         }
 358
 359         my $userenv = C4::Context->userenv;
 360         my $letter = GetPreparedLetter (
 361             module => $type,
 362             letter_code => $letter_code,
 363             branchcode => $userenv->{branch},
 364             tables => {
 365                 'branches'    => $userenv->{branch},
 366                 'aqbooksellers' => $databookseller,
 367                 'aqcontacts'    => $datacontact,
 368             },
 369             repeat => $dataorders,
 370             want_librarian => 1,
 371         ) or return;
 372
 373         # ... then send mail
 374         my %mail = (
 375             To => join( ',', @email),
 376             Cc             => join( ',', @cc),
 377             From           => $userenv->{emailaddress},
 378             Subject        => Encode::encode( "utf8", "" . $letter->{title} ),
 379             Message        => Encode::encode( "utf8", "" . $letter->{content} ),
 380             'Content-Type' => 'text/plain; charset="utf8"',
 381         );
 382
 383         $mail{'Reply-to'} = C4::Context->preference('ReplytoDefault')
 384           if C4::Context->preference('ReplytoDefault');
 385         $mail{'Sender'} = C4::Context->preference('ReturnpathDefault')
 386           if C4::Context->preference('ReturnpathDefault');
 387
 388         unless ( sendmail(%mail) ) {
 389             carp $Mail::Sendmail::error;
 390             return { error => $Mail::Sendmail::error };
 391         }
 392
 393         logaction(
 394             "ACQUISITION",
 395             $type eq 'claimissues' ? "CLAIM ISSUE" : "ACQUISITION CLAIM",
 396             undef,
 397             "To="
 398                 . join( ',', @email )
 399                 . " Title="
 400                 . $letter->{title}
 401                 . " Content="
 402                 . $letter->{content}
 403         ) if C4::Context->preference("LetterLog");
 404     }
 405    # send an "account details" notice to a newly created user
 406     elsif ( $type eq 'members' ) {
 407         my $branchdetails = GetBranchDetail($externalid->{'branchcode'});
 408         my $letter = GetPreparedLetter (
 409             module => 'members',
 410             letter_code => $letter_code,
 411             branchcode => $externalid->{'branchcode'},
 412             tables => {
 413                 'branches'    => $branchdetails,
 414                 'borrowers' => $externalid->{'borrowernumber'},
 415             },
 416             substitute => { 'borrowers.password' => $externalid->{'password'} },
 417             want_librarian => 1,
 418         ) or return;
 419         return { error => "no_email" } unless $externalid->{'emailaddr'};
 420         my $email = Koha::Email->new();
 421         my %mail  = $email->create_message_headers(
 422             {
 423                 to      => $externalid->{'emailaddr'},
 424                 from    => $branchdetails->{'branchemail'},
 425                 replyto => $branchdetails->{'branchreplyto'},
 426                 sender  => $branchdetails->{'branchreturnpath'},
 427                 subject => Encode::encode( "utf8", "" . $letter->{'title'} ),
 428                 message => Encode::encode( "utf8", "" . $letter->{'content'} ),
 429                 contenttype => 'text/plain; charset="utf8"'
 430             }
 431         );
 432         sendmail(%mail) or carp $Mail::Sendmail::error;
 433     }
 434 }
 435
 436 =head2 GetPreparedLetter( %params )
 437
 438     %params hash:
 439       module => letter module, mandatory
 440       letter_code => letter code, mandatory
 441       branchcode => for letter selection, if missing default system letter taken
 442       tables => a hashref with table names as keys. Values are either:
 443         - a scalar - primary key value
 444         - an arrayref - primary key values
 445         - a hashref - full record
 446       substitute => custom substitution key/value pairs
 447       repeat => records to be substituted on consecutive lines:
 448         - an arrayref - tries to guess what needs substituting by
 449           taking remaining << >> tokensr; not recommended
 450         - a hashref token => @tables - replaces <token> << >> << >> </token>
 451           subtemplate for each @tables row; table is a hashref as above
 452       want_librarian => boolean,  if set to true triggers librarian details
 453         substitution from the userenv
 454     Return value:
 455       letter fields hashref (title & content useful)
 456
 457 =cut
 458
 459 sub GetPreparedLetter {
 460     my %params = @_;
 461
 462     my $module      = $params{module} or croak "No module";
 463     my $letter_code = $params{letter_code} or croak "No letter_code";
 464     my $branchcode  = $params{branchcode} || '';
 465     my $mtt         = $params{message_transport_type} || 'email';
 466
 467     my $letter = getletter( $module, $letter_code, $branchcode, $mtt )
 468         or warn( "No $module $letter_code letter transported by " . $mtt ),
 469             return;
 470
 471     my $tables = $params{tables};
 472     my $substitute = $params{substitute};
 473     my $repeat = $params{repeat};
 474     $tables || $substitute || $repeat
 475       or carp( "ERROR: nothing to substitute - both 'tables' and 'substitute' are empty" ),
 476          return;
 477     my $want_librarian = $params{want_librarian};
 478
 479     if ($substitute) {
 480         while ( my ($token, $val) = each %$substitute ) {
 481             $letter->{title} =~ s/<<$token>>/$val/g;
 482             $letter->{content} =~ s/<<$token>>/$val/g;
 483        }
 484     }
 485
 486     my $OPACBaseURL = C4::Context->preference('OPACBaseURL');
 487     $letter->{content} =~ s/<<OPACBaseURL>>/$OPACBaseURL/go;
 488
 489     if ($want_librarian) {
 490         # parsing librarian name
 491         my $userenv = C4::Context->userenv;
 492         $letter->{content} =~ s/<<LibrarianFirstname>>/$userenv->{firstname}/go;
 493         $letter->{content} =~ s/<<LibrarianSurname>>/$userenv->{surname}/go;
 494         $letter->{content} =~ s/<<LibrarianEmailaddress>>/$userenv->{emailaddress}/go;
 495     }
 496
 497     my ($repeat_no_enclosing_tags, $repeat_enclosing_tags);
 498
 499     if ($repeat) {
 500         if (ref ($repeat) eq 'ARRAY' ) {
 501             $repeat_no_enclosing_tags = $repeat;
 502         } else {
 503             $repeat_enclosing_tags = $repeat;
 504         }
 505     }
 506
 507     if ($repeat_enclosing_tags) {
 508         while ( my ($tag, $tag_tables) = each %$repeat_enclosing_tags ) {
 509             if ( $letter->{content} =~ m!<$tag>(.*)</$tag>!s ) {
 510                 my $subcontent = $1;
 511                 my @lines = map {
 512                     my %subletter = ( title => '', content => $subcontent );
 513                     _substitute_tables( \%subletter, $_ );
 514                     $subletter{content};
 515                 } @$tag_tables;
 516                 $letter->{content} =~ s!<$tag>.*</$tag>!join( "\n", @lines )!se;
 517             }
 518         }
 519     }
 520
 521     if ($tables) {
 522         _substitute_tables( $letter, $tables );
 523     }
 524
 525     if ($repeat_no_enclosing_tags) {
 526         if ( $letter->{content} =~ m/[^\n]*<<.*>>[^\n]*/so ) {
 527             my $line = $&;
 528             my $i = 1;
 529             my @lines = map {
 530                 my $c = $line;
 531                 $c =~ s/<<count>>/$i/go;
 532                 foreach my $field ( keys %{$_} ) {
 533                     $c =~ s/(<<[^\.]+.$field>>)/$_->{$field}/;
 534                 }
 535                 $i++;
 536                 $c;
 537             } @$repeat_no_enclosing_tags;
 538
 539             my $replaceby = join( "\n", @lines );
 540             $letter->{content} =~ s/\Q$line\E/$replaceby/s;
 541         }
 542     }
 543
 544     $letter->{content} =~ s/<<\S*>>//go; #remove any stragglers
 545 #   $letter->{content} =~ s/<<[^>]*>>//go;
 546
 547     return $letter;
 548 }
 549
 550 sub _substitute_tables {
 551     my ( $letter, $tables ) = @_;
 552     while ( my ($table, $param) = each %$tables ) {
 553         next unless $param;
 554
 555         my $ref = ref $param;
 556
 557         my $values;
 558         if ($ref && $ref eq 'HASH') {
 559             $values = $param;
 560         }
 561         else {
 562             my @pk;
 563             my $sth = _parseletter_sth($table);
 564             unless ($sth) {
 565                 warn "_parseletter_sth('$table') failed to return a valid sth.  No substitution will be done for that table.";
 566                 return;
 567             }
 568             $sth->execute( $ref ? @$param : $param );
 569
 570             $values = $sth->fetchrow_hashref;
 571             $sth->finish();
 572         }
 573
 574         _parseletter ( $letter, $table, $values );
 575     }
 576 }
 577
 578 sub _parseletter_sth {
 579     my $table = shift;
 580     my $sth;
 581     unless ($table) {
 582         carp "ERROR: _parseletter_sth() called without argument (table)";
 583         return;
 584     }
 585     # NOTE: we used to check whether we had a statement handle cached in
 586     #       a %handles module-level variable. This was a dumb move and
 587     #       broke things for the rest of us. prepare_cached is a better
 588     #       way to cache statement handles anyway.
 589     my $query =
 590     ($table eq 'biblio'       ) ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 591     ($table eq 'biblioitems'  ) ? "SELECT * FROM $table WHERE   biblionumber = ?"                                  :
 592     ($table eq 'items'        ) ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 593     ($table eq 'issues'       ) ? "SELECT * FROM $table WHERE     itemnumber = ?"                                  :
 594     ($table eq 'old_issues'   ) ? "SELECT * FROM $table WHERE     itemnumber = ? ORDER BY timestamp DESC LIMIT 1"  :
 595     ($table eq 'reserves'     ) ? "SELECT * FROM $table WHERE borrowernumber = ? and biblionumber = ?"             :
 596     ($table eq 'borrowers'    ) ? "SELECT * FROM $table WHERE borrowernumber = ?"                                  :
 597     ($table eq 'branches'     ) ? "SELECT * FROM $table WHERE     branchcode = ?"                                  :
 598     ($table eq 'suggestions'  ) ? "SELECT * FROM $table WHERE   suggestionid = ?"                                  :
 599     ($table eq 'aqbooksellers') ? "SELECT * FROM $table WHERE             id = ?"                                  :
 600     ($table eq 'aqorders'     ) ? "SELECT * FROM $table WHERE    ordernumber = ?"                                  :
 601     ($table eq 'opac_news'    ) ? "SELECT * FROM $table WHERE          idnew = ?"                                  :
 602     ($table eq 'borrower_modifications') ? "SELECT * FROM $table WHERE ( borrowernumber = 0 OR borrowernumber = ? ) AND ( verification_token = '' OR verification_token = ? ) AND ( verification_token != '' OR borrowernumber != 0 )" :
 603     undef ;
 604     unless ($query) {
 605         warn "ERROR: No _parseletter_sth query for table '$table'";
 606         return;     # nothing to get
 607     }
 608     unless ($sth = C4::Context->dbh->prepare_cached($query)) {
 609         warn "ERROR: Failed to prepare query: '$query'";
 610         return;
 611     }
 612     return $sth;    # now cache is populated for that $table
 613 }
 614
 615 =head2 _parseletter($letter, $table, $values)
 616
 617     parameters :
 618     - $letter : a hash to letter fields (title & content useful)
 619     - $table : the Koha table to parse.
 620     - $values : table record hashref
 621     parse all fields from a table, and replace values in title & content with the appropriate value
 622     (not exported sub, used only internally)
 623
 624 =cut
 625
 626 sub _parseletter {
 627     my ( $letter, $table, $values ) = @_;
 628
 629     if ( $table eq 'reserves' && $values->{'waitingdate'} ) {
 630         my @waitingdate = split /-/, $values->{'waitingdate'};
 631
 632         $values->{'expirationdate'} = '';
 633         if( C4::Context->preference('ExpireReservesMaxPickUpDelay') &&
 634         C4::Context->preference('ReservesMaxPickUpDelay') ) {
 635             my $dt = dt_from_string();
 636             $dt->add( days => C4::Context->preference('ReservesMaxPickUpDelay') );
 637             $values->{'expirationdate'} = output_pref({ dt => $dt, dateonly => 1 });
 638         }
 639
 640         $values->{'waitingdate'} = output_pref({ dt => dt_from_string( $values->{'waitingdate'} ), dateonly => 1 });
 641
 642     }
 643
 644     if ($letter->{content} && $letter->{content} =~ /<<today>>/) {
 645         my $todaysdate = output_pref( DateTime->now() );
 646         $letter->{content} =~ s/<<today>>/$todaysdate/go;
 647     }
 648
 649     while ( my ($field, $val) = each %$values ) {
 650         my $replacetablefield = "<<$table.$field>>";
 651         my $replacefield = "<<$field>>";
 652         $val =~ s/\p{P}$// if $val && $table=~/biblio/;
 653             #BZ 9886: Assuming that we want to eliminate ISBD punctuation here
 654             #Therefore adding the test on biblio. This includes biblioitems,
 655             #but excludes items. Removed unneeded global and lookahead.
 656
 657         $val = GetAuthorisedValueByCode ('ROADTYPE', $val, 0) if $table=~/^borrowers$/ && $field=~/^streettype$/;
 658         my $replacedby   = defined ($val) ? $val : '';
 659         if (    $replacedby
 660             and not $replacedby =~ m|0000-00-00|
 661             and not $replacedby =~ m|9999-12-31|
 662             and $replacedby =~ m|^\d{4}-\d{2}-\d{2}( \d{2}:\d{2}:\d{2})?$| )
 663         {
 664             # If the value is XXXX-YY-ZZ[ AA:BB:CC] we assume it is a date
 665             my $dateonly = defined $1 ? 0 : 1; #$1 refers to the capture group wrapped in parentheses. In this case, that's the hours, minutes, seconds.
 666             eval {
 667                 $replacedby = output_pref({ dt => dt_from_string( $replacedby ), dateonly => $dateonly });
 668             };
 669             warn "$replacedby seems to be a date but an error occurs on generating it ($@)" if $@;
 670         }
 671         ($letter->{title}  ) and do {
 672             $letter->{title}   =~ s/$replacetablefield/$replacedby/g;
 673             $letter->{title}   =~ s/$replacefield/$replacedby/g;
 674         };
 675         ($letter->{content}) and do {
 676             $letter->{content} =~ s/$replacetablefield/$replacedby/g;
 677             $letter->{content} =~ s/$replacefield/$replacedby/g;
 678         };
 679     }
 680
 681     if ($table eq 'borrowers' && $letter->{content}) {
 682         if ( my $attributes = GetBorrowerAttributes($values->{borrowernumber}) ) {
 683             my %attr;
 684             foreach (@$attributes) {
 685                 my $code = $_->{code};
 686                 my $val  = $_->{value_description} || $_->{value};
 687                 $val =~ s/\p{P}(?=$)//g if $val;
 688                 next unless $val gt '';
 689                 $attr{$code} ||= [];
 690                 push @{ $attr{$code} }, $val;
 691             }
 692             while ( my ($code, $val_ar) = each %attr ) {
 693                 my $replacefield = "<<borrower-attribute:$code>>";
 694                 my $replacedby   = join ',', @$val_ar;
 695                 $letter->{content} =~ s/$replacefield/$replacedby/g;
 696             }
 697         }
 698     }
 699     return $letter;
 700 }
 701
 702 =head2 EnqueueLetter
 703
 704   my $success = EnqueueLetter( { letter => $letter,
 705         borrowernumber => '12', message_transport_type => 'email' } )
 706
 707 places a letter in the message_queue database table, which will
 708 eventually get processed (sent) by the process_message_queue.pl
 709 cronjob when it calls SendQueuedMessages.
 710
 711 return message_id on success
 712
 713 =cut
 714
 715 sub EnqueueLetter {
 716     my $params = shift or return;
 717
 718     return unless exists $params->{'letter'};
 719 #   return unless exists $params->{'borrowernumber'};
 720     return unless exists $params->{'message_transport_type'};
 721
 722     my $content = $params->{letter}->{content};
 723     $content =~ s/\s+//g if(defined $content);
 724     if ( not defined $content or $content eq '' ) {
 725         warn "Trying to add an empty message to the message queue" if $debug;
 726         return;
 727     }
 728
 729     # If we have any attachments we should encode then into the body.
 730     if ( $params->{'attachments'} ) {
 731         $params->{'letter'} = _add_attachments(
 732             {   letter      => $params->{'letter'},
 733                 attachments => $params->{'attachments'},
 734                 message     => MIME::Lite->new( Type => 'multipart/mixed' ),
 735             }
 736         );
 737     }
 738
 739     my $dbh       = C4::Context->dbh();
 740     my $statement = << 'ENDSQL';
 741 INSERT INTO message_queue
 742 ( borrowernumber, subject, content, metadata, letter_code, message_transport_type, status, time_queued, to_address, from_address, content_type )
 743 VALUES
 744 ( ?,              ?,       ?,       ?,        ?,           ?,                      ?,      NOW(),       ?,          ?,            ? )
 745 ENDSQL
 746
 747     my $sth    = $dbh->prepare($statement);
 748     my $result = $sth->execute(
 749         $params->{'borrowernumber'},              # borrowernumber
 750         $params->{'letter'}->{'title'},           # subject
 751         $params->{'letter'}->{'content'},         # content
 752         $params->{'letter'}->{'metadata'} || '',  # metadata
 753         $params->{'letter'}->{'code'}     || '',  # letter_code
 754         $params->{'message_transport_type'},      # message_transport_type
 755         'pending',                                # status
 756         $params->{'to_address'},                  # to_address
 757         $params->{'from_address'},                # from_address
 758         $params->{'letter'}->{'content-type'},    # content_type
 759     );
 760     return $dbh->last_insert_id(undef,undef,'message_queue', undef);
 761 }
 762
 763 =head2 SendQueuedMessages ([$hashref])
 764
 765   my $sent = SendQueuedMessages( { verbose => 1 } );
 766
 767 sends all of the 'pending' items in the message queue.
 768
 769 returns number of messages sent.
 770
 771 =cut
 772
 773 sub SendQueuedMessages {
 774     my $params = shift;
 775
 776     my $unsent_messages = _get_unsent_messages();
 777     MESSAGE: foreach my $message ( @$unsent_messages ) {
 778         # warn Data::Dumper->Dump( [ $message ], [ 'message' ] );
 779         warn sprintf( 'sending %s message to patron: %s',
 780                       $message->{'message_transport_type'},
 781                       $message->{'borrowernumber'} || 'Admin' )
 782           if $params->{'verbose'} or $debug;
 783         # This is just begging for subclassing
 784         next MESSAGE if ( lc($message->{'message_transport_type'}) eq 'rss' );
 785         if ( lc( $message->{'message_transport_type'} ) eq 'email' ) {
 786             _send_message_by_email( $message, $params->{'username'}, $params->{'password'}, $params->{'method'} );
 787         }
 788         elsif ( lc( $message->{'message_transport_type'} ) eq 'sms' ) {
 789             _send_message_by_sms( $message );
 790         }
 791     }
 792     return scalar( @$unsent_messages );
 793 }
 794
 795 =head2 GetRSSMessages
 796
 797   my $message_list = GetRSSMessages( { limit => 10, borrowernumber => '14' } )
 798
 799 returns a listref of all queued RSS messages for a particular person.
 800
 801 =cut
 802
 803 sub GetRSSMessages {
 804     my $params = shift;
 805
 806     return unless $params;
 807     return unless ref $params;
 808     return unless $params->{'borrowernumber'};
 809
 810     return _get_unsent_messages( { message_transport_type => 'rss',
 811                                    limit                  => $params->{'limit'},
 812                                    borrowernumber         => $params->{'borrowernumber'}, } );
 813 }
 814
 815 =head2 GetPrintMessages
 816
 817   my $message_list = GetPrintMessages( { borrowernumber => $borrowernumber } )
 818
 819 Returns a arrayref of all queued print messages (optionally, for a particular
 820 person).
 821
 822 =cut
 823
 824 sub GetPrintMessages {
 825     my $params = shift || {};
 826
 827     return _get_unsent_messages( { message_transport_type => 'print',
 828                                    borrowernumber         => $params->{'borrowernumber'},
 829                                  } );
 830 }
 831
 832 =head2 GetQueuedMessages ([$hashref])
 833
 834   my $messages = GetQueuedMessage( { borrowernumber => '123', limit => 20 } );
 835
 836 fetches messages out of the message queue.
 837
 838 returns:
 839 list of hashes, each has represents a message in the message queue.
 840
 841 =cut
 842
 843 sub GetQueuedMessages {
 844     my $params = shift;
 845
 846     my $dbh = C4::Context->dbh();
 847     my $statement = << 'ENDSQL';
 848 SELECT message_id, borrowernumber, subject, content, message_transport_type, status, time_queued
 849 FROM message_queue
 850 ENDSQL
 851
 852     my @query_params;
 853     my @whereclauses;
 854     if ( exists $params->{'borrowernumber'} ) {
 855         push @whereclauses, ' borrowernumber = ? ';
 856         push @query_params, $params->{'borrowernumber'};
 857     }
 858
 859     if ( @whereclauses ) {
 860         $statement .= ' WHERE ' . join( 'AND', @whereclauses );
 861     }
 862
 863     if ( defined $params->{'limit'} ) {
 864         $statement .= ' LIMIT ? ';
 865         push @query_params, $params->{'limit'};
 866     }
 867
 868     my $sth = $dbh->prepare( $statement );
 869     my $result = $sth->execute( @query_params );
 870     return $sth->fetchall_arrayref({});
 871 }
 872
 873 =head2 GetMessageTransportTypes
 874
 875   my @mtt = GetMessageTransportTypes();
 876
 877   returns an arrayref of transport types
 878
 879 =cut
 880
 881 sub GetMessageTransportTypes {
 882     my $dbh = C4::Context->dbh();
 883     my $mtts = $dbh->selectcol_arrayref("
 884         SELECT message_transport_type
 885         FROM message_transport_types
 886         ORDER BY message_transport_type
 887     ");
 888     return $mtts;
 889 }
 890
 891 =head2 _add_attachements
 892
 893 named parameters:
 894 letter - the standard letter hashref
 895 attachments - listref of attachments. each attachment is a hashref of:
 896   type - the mime type, like 'text/plain'
 897   content - the actual attachment
 898   filename - the name of the attachment.
 899 message - a MIME::Lite object to attach these to.
 900
 901 returns your letter object, with the content updated.
 902
 903 =cut
 904
 905 sub _add_attachments {
 906     my $params = shift;
 907
 908     my $letter = $params->{'letter'};
 909     my $attachments = $params->{'attachments'};
 910     return $letter unless @$attachments;
 911     my $message = $params->{'message'};
 912
 913     # First, we have to put the body in as the first attachment
 914     $message->attach(
 915         Type => $letter->{'content-type'} || 'TEXT',
 916         Data => $letter->{'is_html'}
 917             ? _wrap_html($letter->{'content'}, $letter->{'title'})
 918             : $letter->{'content'},
 919     );
 920
 921     foreach my $attachment ( @$attachments ) {
 922         $message->attach(
 923             Type     => $attachment->{'type'},
 924             Data     => $attachment->{'content'},
 925             Filename => $attachment->{'filename'},
 926         );
 927     }
 928     # we're forcing list context here to get the header, not the count back from grep.
 929     ( $letter->{'content-type'} ) = grep( /^Content-Type:/, split( /\n/, $params->{'message'}->header_as_string ) );
 930     $letter->{'content-type'} =~ s/^Content-Type:\s+//;
 931     $letter->{'content'} = $message->body_as_string;
 932
 933     return $letter;
 934
 935 }
 936
 937 sub _get_unsent_messages {
 938     my $params = shift;
 939
 940     my $dbh = C4::Context->dbh();
 941     my $statement = << 'ENDSQL';
 942 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
 943   FROM message_queue mq
 944   LEFT JOIN borrowers b ON b.borrowernumber = mq.borrowernumber
 945  WHERE status = ?
 946 ENDSQL
 947
 948     my @query_params = ('pending');
 949     if ( ref $params ) {
 950         if ( $params->{'message_transport_type'} ) {
 951             $statement .= ' AND message_transport_type = ? ';
 952             push @query_params, $params->{'message_transport_type'};
 953         }
 954         if ( $params->{'borrowernumber'} ) {
 955             $statement .= ' AND borrowernumber = ? ';
 956             push @query_params, $params->{'borrowernumber'};
 957         }
 958         if ( $params->{'limit'} ) {
 959             $statement .= ' limit ? ';
 960             push @query_params, $params->{'limit'};
 961         }
 962     }
 963
 964     $debug and warn "_get_unsent_messages SQL: $statement";
 965     $debug and warn "_get_unsent_messages params: " . join(',',@query_params);
 966     my $sth = $dbh->prepare( $statement );
 967     my $result = $sth->execute( @query_params );
 968     return $sth->fetchall_arrayref({});
 969 }
 970
 971 sub _send_message_by_email {
 972     my $message = shift or return;
 973     my ($username, $password, $method) = @_;
 974
 975     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
 976     my $to_address = $message->{'to_address'};
 977     unless ($to_address) {
 978         unless ($member) {
 979             warn "FAIL: No 'to_address' and INVALID borrowernumber ($message->{borrowernumber})";
 980             _set_message_status( { message_id => $message->{'message_id'},
 981                                    status     => 'failed' } );
 982             return;
 983         }
 984         $to_address = C4::Members::GetNoticeEmailAddress( $message->{'borrowernumber'} );
 985         unless ($to_address) {
 986             # warn "FAIL: No 'to_address' and no email for " . ($member->{surname} ||'') . ", borrowernumber ($message->{borrowernumber})";
 987             # warning too verbose for this more common case?
 988             _set_message_status( { message_id => $message->{'message_id'},
 989                                    status     => 'failed' } );
 990             return;
 991         }
 992     }
 993
 994     my $utf8   = decode('MIME-Header', $message->{'subject'} );
 995     $message->{subject}= encode('MIME-Header', $utf8);
 996     my $subject = encode('utf8', $message->{'subject'});
 997     my $content = encode('utf8', $message->{'content'});
 998     my $content_type = $message->{'content_type'} || 'text/plain; charset="UTF-8"';
 999     my $is_html = $content_type =~ m/html/io;
1000     my $branch_email = undef;
1001     my $branch_replyto = undef;
1002     my $branch_returnpath = undef;
1003     if ($member){
1004         my $branchdetail = GetBranchDetail( $member->{'branchcode'} );
1005         $branch_email = $branchdetail->{'branchemail'};
1006         $branch_replyto = $branchdetail->{'branchreplyto'};
1007         $branch_returnpath = $branchdetail->{'branchreturnpath'};
1008     }
1009     my $email = Koha::Email->new();
1010     my %sendmail_params = $email->create_message_headers(
1011         {
1012             to      => $to_address,
1013             from    => $message->{'from_address'} || $branch_email,
1014             replyto => $branch_replyto,
1015             sender  => $branch_returnpath,
1016             subject => $subject,
1017             message => $is_html ? _wrap_html( $content, $subject ) : $content,
1018             contenttype => $content_type
1019         }
1020     );
1021
1022     $sendmail_params{'Auth'} = {user => $username, pass => $password, method => $method} if $username;
1023     if ( my $bcc = C4::Context->preference('OverdueNoticeBcc') ) {
1024        $sendmail_params{ Bcc } = $bcc;
1025     }
1026
1027     _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
1028     if ( sendmail( %sendmail_params ) ) {
1029         _set_message_status( { message_id => $message->{'message_id'},
1030                 status     => 'sent' } );
1031         return 1;
1032     } else {
1033         _set_message_status( { message_id => $message->{'message_id'},
1034                 status     => 'failed' } );
1035         carp $Mail::Sendmail::error;
1036         return;
1037     }
1038 }
1039
1040 sub _wrap_html {
1041     my ($content, $title) = @_;
1042
1043     my $css = C4::Context->preference("NoticeCSS") || '';
1044     $css = qq{<link rel="stylesheet" type="text/css" href="$css">} if $css;
1045     return <<EOS;
1046 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"
1047     "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
1048 <html lang="en" xml:lang="en" xmlns="http://www.w3.org/1999/xhtml">
1049 <head>
1050 <title>$title</title>
1051 <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
1052 $css
1053 </head>
1054 <body>
1055 $content
1056 </body>
1057 </html>
1058 EOS
1059 }
1060
1061 sub _is_duplicate {
1062     my ( $message ) = @_;
1063     my $dbh = C4::Context->dbh;
1064     my $count = $dbh->selectrow_array(q|
1065         SELECT COUNT(*)
1066         FROM message_queue
1067         WHERE message_transport_type = ?
1068         AND borrowernumber = ?
1069         AND letter_code = ?
1070         AND CAST(time_queued AS date) = CAST(NOW() AS date)
1071         AND status="sent"
1072         AND content = ?
1073     |, {}, $message->{message_transport_type}, $message->{borrowernumber}, $message->{letter_code}, $message->{content} );
1074     return $count;
1075 }
1076
1077 sub _send_message_by_sms {
1078     my $message = shift or return;
1079     my $member = C4::Members::GetMember( 'borrowernumber' => $message->{'borrowernumber'} );
1080
1081     unless ( $member->{smsalertnumber} ) {
1082         _set_message_status( { message_id => $message->{'message_id'},
1083                                status     => 'failed' } );
1084         return;
1085     }
1086
1087     if ( _is_duplicate( $message ) ) {
1088         _set_message_status( { message_id => $message->{'message_id'},
1089                                status     => 'failed' } );
1090         return;
1091     }
1092
1093     my $success = C4::SMS->send_sms( { destination => $member->{'smsalertnumber'},
1094                                        message     => $message->{'content'},
1095                                      } );
1096     _set_message_status( { message_id => $message->{'message_id'},
1097                            status     => ($success ? 'sent' : 'failed') } );
1098     return $success;
1099 }
1100
1101 sub _update_message_to_address {
1102     my ($id, $to)= @_;
1103     my $dbh = C4::Context->dbh();
1104     $dbh->do('UPDATE message_queue SET to_address=? WHERE message_id=?',undef,($to,$id));
1105 }
1106
1107 sub _set_message_status {
1108     my $params = shift or return;
1109
1110     foreach my $required_parameter ( qw( message_id status ) ) {
1111         return unless exists $params->{ $required_parameter };
1112     }
1113
1114     my $dbh = C4::Context->dbh();
1115     my $statement = 'UPDATE message_queue SET status= ? WHERE message_id = ?';
1116     my $sth = $dbh->prepare( $statement );
1117     my $result = $sth->execute( $params->{'status'},
1118                                 $params->{'message_id'} );
1119     return $result;
1120 }
1121
1122
1123 1;
1124 __END__