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